home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / edit / jed096_1.zip / SLANG / SRC / SLANG.C < prev    next >
C/C++ Source or Header  |  1994-04-26  |  74KB  |  3,054 lines
  1. /* slang.c  --- guts of S-Lang interpreter */
  2. /* 
  3.  * Copyright (c) 1992, 1994 John E. Davis 
  4.  * All rights reserved.
  5.  *
  6.  * Permission is hereby granted, without written agreement and without
  7.  * license or royalty fees, to use, copy, and distribute this
  8.  * software and its documentation for any purpose, provided that the
  9.  * above copyright notice and the following two paragraphs appear in
  10.  * all copies of this software.
  11.  *
  12.  * IN NO EVENT SHALL JOHN E. DAVIS BE LIABLE TO ANY PARTY FOR DIRECT,
  13.  * INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF
  14.  * THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF JOHN E. DAVIS
  15.  * HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  16.  *
  17.  * JOHN E. DAVIS SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT NOT
  18.  * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
  19.  * PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS"
  20.  * BASIS, AND JOHN E. DAVIS HAS NO OBLIGATION TO PROVIDE MAINTENANCE,
  21.  * SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  22.  */
  23.  
  24. #include <stdio.h>
  25.  
  26. #ifdef FLOAT_TYPE
  27. char SLang_Version[] = "F0.98";
  28. #include <math.h>
  29. #else
  30. char SLang_Version[] = "0.98";
  31. #endif
  32.  
  33. /* not ready yet */
  34. /* #define SL_BYTE_COMPILING */
  35.  
  36. #include "slang.h"
  37. #include "_slang.h"
  38.  
  39. /* If non null, these call C functions before and after a slang function. */
  40. void (*SLang_Enter_Function)(char *) = NULL;
  41. void (*SLang_Exit_Function)(char *) = NULL;
  42.  
  43. int SLang_Trace = 0;
  44. char SLang_Trace_Function[32];
  45.  
  46.  
  47. SLang_Name_Type SLang_Name_Table[LANG_MAX_SYMBOLS];
  48. int SLang_Name_Table_Ofs[256];
  49. SLName_Table *SLName_Table_Root;
  50.  
  51.  
  52. SLang_Name_Type *Lang_Local_Variable_Table;
  53. int Local_Variable_Number;
  54. #define MAX_LOCAL_VARIABLES 50
  55.  
  56. int Lang_Break_Condition = 0;           /* true if any one below is true */
  57. int Lang_Break = 0;
  58. int Lang_Return = 0;
  59. int Lang_Continue = 0;
  60.  
  61. /* this stack is used by the inner interpreter to execute top level
  62.    interpreter commands which by definition are immediate so stack is
  63.    only of maximum 10; sorry... */
  64. #define SLANG_MAX_TOP_STACK 10
  65. SLBlock_Type Lang_Interp_Stack_Static[SLANG_MAX_TOP_STACK];
  66. SLBlock_Type *Lang_Interp_Stack_Ptr = Lang_Interp_Stack_Static;
  67. SLBlock_Type *Lang_Interp_Stack = Lang_Interp_Stack_Static;
  68.  
  69. SLang_Object_Type SLRun_Stack[LANG_MAX_STACK_LEN];
  70. SLang_Object_Type *SLStack_Pointer = SLRun_Stack;
  71. SLang_Object_Type *SLStack_Pointer_Max = SLRun_Stack + LANG_MAX_STACK_LEN;
  72.  
  73. /* Might want to increase this. */
  74. #define MAX_LOCAL_STACK 200
  75. SLang_Object_Type Local_Variable_Stack[MAX_LOCAL_STACK];
  76.  
  77. SLang_Object_Type *Local_Variable_Frame = Local_Variable_Stack;
  78.  
  79. volatile int SLang_Error = 0;
  80. int SLang_Traceback = 0;               /* non zero means do traceback */
  81.  
  82. extern int inner_interp(register SLBlock_Type *);
  83.  
  84. int Lang_Defining_Function = 0;   /* true if defining a function */
  85. SLBlock_Type *Lang_Function_Body;
  86. SLBlock_Type *Lang_FBody_Ptr;
  87. int Lang_FBody_Size = 0;
  88.  
  89. #define LANG_MAX_BLOCKS 30
  90. /* max number of nested blocks--- was 10 but I once exceeded it! */
  91.  
  92. typedef struct Lang_Block_Type
  93.   {
  94.      int size;                         /* current nuber of objects malloced */
  95.      SLBlock_Type *body;           /* beginning of body definition */
  96.      SLBlock_Type *ptr;            /* current location */
  97.   }
  98. Lang_Block_Type;
  99.  
  100. int Lang_Defining_Block = 0;   /* true if defining a block */
  101. Lang_Block_Type Lang_Block_Stack[LANG_MAX_BLOCKS];
  102. SLBlock_Type *Lang_Block_Body;
  103. int Lang_BBody_Size;
  104.  
  105. int Lang_Block_Depth = -1;
  106.  
  107. SLBlock_Type *Lang_Object_Ptr = Lang_Interp_Stack_Static;
  108. /* next location for compiled obj -- points to interpreter stack initially */
  109.  
  110. #ifdef VMS
  111. int (*SLang_Error_Routine)(char *) = NULL;
  112. #else
  113. int (*SLang_Error_Routine)(char *) = (int (*)(char *)) NULL;
  114. #endif
  115.  
  116. void SLang_doerror(char *error)
  117. {
  118.    char err[80]; char *str = NULL;
  119.  
  120.    if (!SLang_Error) SLang_Error = UNKNOWN_ERROR;
  121.    *err = 0;
  122.    switch(SLang_Error)
  123.      {
  124.     case (UNDEFINED_NAME): str = "Undefined_Name"; break;
  125.     case (SYNTAX_ERROR): str = "Syntax_Error"; break;
  126.     case (STACK_OVERFLOW): str = "Stack_Overflow"; break;
  127.     case (STACK_UNDERFLOW): str = "Stack_Underflow"; break;
  128.     case (DUPLICATE_DEFINITION): str = "Duplicate_Definition"; break;
  129.     case (TYPE_MISMATCH): str = "Type_Mismatch"; break;
  130.     case(READONLY_ERROR): str = "Variable is read only."; break;
  131.     case (SL_MALLOC_ERROR) : str = "S-Lang: Malloc Error."; break;
  132.     case (SL_INVALID_PARM) : str = "S-Lang: Invalid Parameter."; break;
  133.       case USER_BREAK: strcpy(err, "User Break!"); break;
  134.     case (INTRINSIC_ERROR): str = "Intrinsic Error"; break;
  135.       case DIVIDE_ERROR: str = "Divide by zero."; break;
  136.     /* application code should handle this */
  137.     default: if (error != NULL) str = error; else str = "Unknown Error.";
  138.      }
  139.  
  140.    if (*err == 0) sprintf(err, "S-Lang Error: %s", str);
  141.    
  142.    if (SLang_Error_Routine == NULL)
  143.      {
  144.     if (error != NULL) 
  145.       {
  146.          fputs(error, stderr);
  147.          putc('\n', stderr);
  148.       }
  149.     
  150.     if (err != error) 
  151.       {
  152.          fputs(err, stderr);
  153.          putc('\n', stderr);
  154.       }
  155.      }
  156.    else
  157.      {    if (error != NULL) (*SLang_Error_Routine)(error);
  158.     if (err != error) (*SLang_Error_Routine)(err);
  159.      }
  160. }
  161.  
  162.  
  163. int SLang_pop(SLang_Object_Type *x)
  164. {
  165.    register SLang_Object_Type *y;
  166.    
  167.    y = SLStack_Pointer;
  168.    if (y == SLRun_Stack)
  169.      {
  170.     x->type = 0;
  171.     SLang_Error = STACK_UNDERFLOW;
  172.     SLStack_Pointer = SLRun_Stack;
  173.     return 1;
  174.      }
  175.    y--;
  176.    *x = *y;
  177.  
  178.    SLStack_Pointer = y;
  179.    return(0);
  180. }
  181.  
  182. void SLang_push(SLang_Object_Type *x)
  183. {
  184.    register SLang_Object_Type *y;
  185.    y = SLStack_Pointer;
  186.    
  187.    /* if there is a SLang_Error, probably not much harm will be done
  188.       if it is ignored here */
  189.    /* if (SLang_Error) return; */
  190.    
  191.    /* flag it now */
  192.    if (y >= SLStack_Pointer_Max)
  193.      {
  194.     if (!SLang_Error) SLang_Error = STACK_OVERFLOW;
  195.     return;
  196.      }
  197.    
  198.    *y = *x;
  199.    SLStack_Pointer = y + 1;
  200. }
  201.  
  202. void lang_free_branch(SLBlock_Type *p)
  203. {
  204.    short type; 
  205.    
  206.    while(1)
  207.      {
  208.         type = (p->type);
  209.     if ((type & 0xFF) == LANG_BLOCK)
  210.       {
  211.          lang_free_branch(p->b.blk);
  212.          FREE(p->b.blk);
  213.       }
  214. #ifdef FLOAT_TYPE
  215.     else if (type == (LANG_LITERAL | (FLOAT_TYPE << 8)))
  216.       {
  217.          FREE (p->b.f_blk);
  218.       }
  219. #endif
  220.     /* else if (type == string_type) FREE(p->value);
  221.      This fails because objects may be attached to these strings */
  222.     else if (type == 0) break;
  223.     p++;
  224.      }
  225. }
  226.  
  227. int SLang_pop_integer(int *i)
  228. {
  229.    SLang_Object_Type obj;
  230.  
  231.    if (SLang_pop(&obj) ||  ((obj.type >> 8) != INT_TYPE))
  232.      {
  233.     if (!SLang_Error) SLang_Error = TYPE_MISMATCH;
  234.     return(1);
  235.      }
  236.  
  237.    *i = obj.v.i_val;
  238.    return(0);
  239. }
  240.  
  241. #ifdef FLOAT_TYPE
  242. int SLang_pop_float(FLOAT *x, int *convert, int *ip)
  243. {
  244.    SLang_Object_Type obj;
  245.    register unsigned char stype;
  246.  
  247.    if (SLang_pop(&obj)) return(1);
  248.    stype = obj.type >> 8;
  249.  
  250.    if (stype == FLOAT_TYPE) 
  251.      {
  252.     *x = obj.v.f_val;
  253.     *convert = 0;
  254.      }
  255.    else if (stype == INT_TYPE) 
  256.      {
  257.     *ip = obj.v.i_val;
  258.     *x = (FLOAT) obj.v.i_val;
  259.     *convert = 1;
  260.      }
  261.    else
  262.      {
  263.     SLang_Error = TYPE_MISMATCH;
  264.     return(1);
  265.      }
  266.    return(0);
  267. }
  268.  
  269. void SLang_push_float(FLOAT x)
  270. {
  271.    SLang_Object_Type obj;
  272.  
  273.    obj.type = LANG_DATA | (FLOAT_TYPE << 8);
  274.    obj.v.f_val = x;
  275.    SLang_push (&obj);
  276. }
  277.  
  278. #endif
  279.  
  280. /* if *data = 1, string should be freed upon use.  If it is -1, do not free
  281.    but if you use it, malloc a new one.  */
  282. int SLang_pop_string(char **s, int *data)
  283. {
  284.    SLang_Object_Type obj;
  285.    
  286.    if (SLang_pop(&obj) || ((obj.type >> 8) != STRING_TYPE))
  287.      {
  288.     if (!SLang_Error) SLang_Error = TYPE_MISMATCH;
  289.     return(1);
  290.      }
  291.  
  292.    
  293.    *s = obj.v.s_val;
  294.    /* return whether or not this should be freed after its use. */
  295.    if ((obj.type & 0xFF) == LANG_DATA) *data = 1;
  296.    else *data = 0;
  297.    
  298.    return(0);
  299. }
  300.  
  301. void SLang_push_integer(int i)
  302. {
  303.    SLang_Object_Type obj;
  304.  
  305.    obj.type = LANG_DATA | (INT_TYPE << 8);
  306.    obj.v.i_val = i;
  307.    SLang_push (&obj);
  308. }
  309.  
  310. char *SLmake_string(char *str)
  311. {
  312.    char *ptr;
  313.    int n = strlen (str);
  314.    
  315.    if (NULL == (ptr = (char *) MALLOC(n + 1)))
  316.      {
  317.     SLang_Error = SL_MALLOC_ERROR;
  318.     /* SLang_doerror("malloc error in lang_make_string."); */
  319.     return(NULL);
  320.      }
  321.    strcpy(ptr, str);
  322.    return(ptr);
  323. }
  324.  
  325. void SLang_push_string(char *t)
  326. {
  327.    SLang_Object_Type obj;
  328.    if (NULL == (obj.v.s_val = SLmake_string(t))) return;
  329.    obj.type = LANG_DATA | (STRING_TYPE << 8);
  330.    SLang_push(&obj);
  331. }
  332.  
  333.  
  334.  
  335. void SLang_push_malloced_string(char *c)
  336. {
  337.    SLang_Object_Type obj;
  338.    
  339.    obj.type = LANG_DATA | (STRING_TYPE << 8);
  340.    obj.v.s_val = c;
  341.    SLang_push(&obj);
  342. }
  343.  
  344.  
  345. int SLatoi(unsigned char *s)
  346. {
  347.    register unsigned char ch;
  348.    register unsigned int i, ich;
  349.    register int base;
  350.    
  351.    if (*s != '0') return atoi((char *) s);
  352.  
  353.    /* look for 'x' which indicates hex */
  354.    s++;
  355.    if (*s == 'x') 
  356.      {
  357.     base = 4;
  358.     s++;
  359.      }
  360.    else base = 3;
  361.    i = 0;
  362.    while ((ch = *s++) != 0)
  363.      {
  364.     if (ch > 64) ich = ch - 55; else ich = ch - 48;
  365.     i = (i << base) | ich;
  366.      }
  367.    return (int) i;
  368. }
  369.  
  370.  
  371.  
  372. static void call_funptr(SLang_Name_Type *);
  373.  
  374. /* This is a global variable */
  375. void SLang_push_variable(SLang_Object_Type *obj)
  376. {
  377.    register unsigned char subtype;
  378.    subtype = obj->type >> 8;
  379.  
  380.    if (subtype == STRING_TYPE)
  381.      {
  382.     SLang_push_string(obj->v.s_val);
  383.     return;
  384.      }
  385.    else if (subtype == LANG_OBJ_TYPE)
  386.      {
  387.     call_funptr(obj->v.n_val);
  388.     return;
  389.      }
  390.    
  391.     SLang_push(obj); 
  392. }
  393.  
  394. /* This routine pops an integer off the stack.  It then adds dn to the 
  395.    value producing n. The it reverses the
  396.    next n items on the stack.  Some functions may require this.
  397.    This returns a pointer to the last item.
  398. */
  399. SLang_Object_Type *SLreverse_stack(int *dn)
  400. {
  401.    int n;
  402.    SLang_Object_Type *otop, *obot, tmp;
  403.    
  404.    if (SLang_pop_integer(&n)) return(NULL);
  405.    n += *dn;
  406.    
  407.    otop = SLStack_Pointer;
  408.    if ((n > otop - SLRun_Stack) || (n < 0))
  409.      {
  410.     SLang_Error = STACK_UNDERFLOW;
  411.     return (NULL);
  412.      }
  413.    obot = otop - n;
  414.    otop--;
  415.    while (otop > obot)
  416.      {
  417.     tmp = *obot;
  418.     *obot = *otop;
  419.     *otop = tmp;
  420.     otop--;
  421.     obot++;
  422.      }
  423.    return (SLStack_Pointer - n);
  424. }
  425.  
  426.    
  427.  
  428.  
  429. /* local and global variable assignments */
  430.  
  431. /* value contains either the offset of data for local variables or
  432.    location of object_type for global ones.  For strings, we have to be
  433.    careful.  Literal (constant) strings which are already attached to these
  434.    variables are not to be freed--- only those of type data (dynamic).
  435.    There is no need to create new strings since they come from the stack.
  436.  
  437.    Note that strings appear on the stack in 2 forms: literal and
  438.    dynamic. Literal strings are constants.  Dynamic ones are created by,
  439.    say, dup, etc. They are freed only by routines which eat them.  These
  440.    routines must check to see if they are not literal types before freeing
  441.    them.  The only other way they are freed is when they are on the local
  442.    variable stack, e.g., (assigned to local variables) and the function
  443.    exits freeing them.
  444.  
  445.    Define Macro to do this:  (defined above)
  446.  
  447. #define IS_DATA_STRING(obj)\
  448.    ((((obj).type & 0xFF) == LANG_DATA) && (((obj).type >> 8) == STRING_TYPE))
  449. */
  450.  
  451.  
  452. /* pop a data item from the stack and return a pointer to it.
  453.    Strings are not freed from stack so use another routine to do it.
  454.  
  455.    In addition, I need to make this work with the array types.  */
  456. /* see pop string for discussion of do_free */
  457. long *SLang_pop_pointer(unsigned short *type, int *do_free)
  458. {
  459.    SLang_Object_Type obj;
  460.    register SLang_Object_Type *p;
  461.    long *val;
  462.  
  463.    if (SLang_pop(&obj)) return(NULL);
  464.    p = SLStack_Pointer;
  465.  
  466.    /* use this because the stack is static but obj is not.
  467.       do not even try to make it static either. See the intrinsic
  468.       routine for details */
  469.    *type = p->type;
  470.    *do_free = 0;
  471.    switch (*type >> 8)
  472.      {
  473. #ifdef FLOAT_TYPE
  474.       case FLOAT_TYPE: val = (long *) &(p->v.f_val);
  475.     break;
  476. #endif
  477.       case INT_TYPE: val = (long *) &(p->v.i_val); break;
  478.       case STRING_TYPE:
  479.     if ((*type & 0xFF) == LANG_DATA) *do_free = 1;
  480.     /* drop */
  481.       default: 
  482.         val = (long *) p->v.s_val;
  483.      }
  484.  
  485.    return (val);
  486. }
  487.  
  488.  
  489. void lang_do_eqs(SLBlock_Type *obj)
  490. {
  491.    int y;
  492. #ifdef FLOAT_TYPE   
  493.    int ifloat, float_convert;
  494. #endif
  495.    register unsigned char type;
  496.    register SLang_Object_Type *addr;
  497.    register long val;
  498.    unsigned short stype;
  499.    
  500.  
  501.    type = obj->type >> 8;
  502.    /* calculate address */
  503.    if (type <= LANG_LMM)
  504.      {
  505.     /* local */
  506.     val = 0;
  507.     addr = Local_Variable_Frame - obj->b.i_blk;
  508.     stype = addr->type;
  509.      }
  510.    
  511.    
  512.    else if (type <= LANG_GMM)           /* global */
  513.      {
  514.     addr = (SLang_Object_Type *) obj->b.n_blk->addr;
  515.     val = 0;
  516.     stype = addr->type;
  517.      }
  518.    else                       /* intrinsic */
  519.      {
  520.     addr = NULL;
  521.     val = obj->b.n_blk->addr;
  522.     stype = obj->b.n_blk->type;;
  523.  
  524.      }
  525.  
  526.    if ((type == LANG_LEQS) || (type == LANG_GEQS))
  527.      {
  528.     if (IS_DATA_STRING(*addr)) FREE(addr->v.s_val);
  529.         SLang_pop(addr);
  530.     return;
  531.      }
  532.      
  533.    /* everything else applies to integers -- later I will extend to float */
  534.    
  535.    if (INT_TYPE != (stype >> 8))
  536.      {
  537. #ifdef FLOAT_TYPE
  538.     /* A quick hack for float */
  539.     if ((FLOAT_TYPE == (stype >> 8)) && (type == LANG_IEQS))
  540.       {
  541.          SLang_pop_float ((FLOAT *) val, &float_convert, &ifloat);
  542.          return;
  543.       }
  544.      
  545. #endif
  546.     SLang_Error = TYPE_MISMATCH;
  547.     return;
  548.      }
  549.  
  550.    /* make this fast for local variables avoiding switch bottleneck */
  551.    if (type == LANG_LPP)
  552.      {
  553.     addr->v.i_val += 1;
  554.     return;
  555.      }
  556.    else if (type == LANG_LMM)
  557.      {
  558.     addr->v.i_val -= 1;
  559.     return;
  560.      }
  561.  
  562.    y = 1;
  563.    switch (type)
  564.      {
  565.       case LANG_LPEQS: 
  566.       case LANG_GPEQS:
  567.     if (SLang_pop_integer(&y)) return;
  568.     /* drop */
  569.       case LANG_GPP: 
  570.     addr->v.i_val += y;
  571.     break;
  572.     
  573.       case LANG_GMEQS: 
  574.       case LANG_LMEQS: 
  575.     if (SLang_pop_integer(&y)) return;
  576.     /* drop */
  577.       case LANG_GMM: 
  578.     addr->v.i_val -= y;
  579.     break;
  580.     
  581.       case LANG_IEQS: 
  582.     if (SLang_pop_integer(&y)) return;
  583.     *(int *) val = y;
  584.     break;
  585.     
  586.       case LANG_IPEQS: 
  587.     if (SLang_pop_integer(&y)) return;
  588.     /* drop */
  589.       case LANG_IPP: 
  590.     *(int *) val += y;
  591.     break;
  592.     
  593.       case LANG_IMEQS:
  594.     if (SLang_pop_integer(&y)) return;
  595.     /* drop */
  596.       case LANG_IMM: 
  597.     *(int *) val -= y;
  598.     break;
  599.       default: 
  600.     SLang_Error = UNKNOWN_ERROR;
  601.      }
  602. }
  603.  
  604. /* lower 4 bits represent the return type, e.g., void, int, etc... 
  605.    The next 4 bits represent the number of parameters, 0 -> 15 */
  606. #define LANG_INTRINSIC_ARGC(f) ((f).type >> 12)
  607. #define LANG_INTRINSIC_TYPE(f) (((f).type & 0x0F00) >> 8)
  608.  
  609. void lang_do_intrinsic(SLang_Name_Type *objf)
  610. {
  611.    typedef void (*VF0_Type)(void);
  612.    typedef void (*VF1_Type)(char *);
  613.    typedef void (*VF2_Type)(char *, char *);
  614.    typedef void (*VF3_Type)(char *, char *, char *);
  615.    typedef void (*VF4_Type)(char *, char *, char *, char *);
  616.    typedef void (*VF5_Type)(char *, char *, char *, char *, char *);
  617.    typedef long (*LF0_Type)(void);
  618.    typedef long (*LF1_Type)(char *);
  619.    typedef long (*LF2_Type)(char *, char *);
  620.    typedef long (*LF3_Type)(char *, char *, char *);
  621.    typedef long (*LF4_Type)(char *, char *, char *, char *);
  622.    typedef long (*LF5_Type)(char *, char *, char *, char *, char *);
  623. #ifdef FLOAT_TYPE
  624.    typedef FLOAT (*FF0_Type)(void);
  625.    typedef FLOAT (*FF1_Type)(char *);
  626.    typedef FLOAT (*FF2_Type)(char *, char *);
  627.    typedef FLOAT (*FF3_Type)(char *, char *, char *);
  628.    typedef FLOAT (*FF4_Type)(char *, char *, char *, char *);
  629.    typedef FLOAT (*FF5_Type)(char *, char *, char *, char *, char *);
  630. #endif
  631.    long ret, fptr;
  632.    char *p1, *p2, *p3, *p4, *p5;
  633.    unsigned short tmp;
  634.    int free_p5 = 0, free_p4 = 0, free_p3 = 0, free_p2 = 0, free_p1 = 0;
  635.    unsigned char type;
  636.    int argc;
  637. #ifdef FLOAT_TYPE
  638.    FLOAT xf;
  639. #endif
  640.  
  641.    fptr = objf->addr;
  642.  
  643.    argc = LANG_INTRINSIC_ARGC(*objf);
  644.    type = LANG_INTRINSIC_TYPE(*objf);
  645.  
  646.    p5 = p4 = p3 = p2 = p1 = NULL;      /* shuts up gcc, NOT needed */
  647.    switch (argc)
  648.      {
  649.     case 5: p5 = (char *) SLang_pop_pointer(&tmp, &free_p5);
  650.     case 4: p4 = (char *) SLang_pop_pointer(&tmp, &free_p4);
  651.     case 3: p3 = (char *) SLang_pop_pointer(&tmp, &free_p3);
  652.     case 2: p2 = (char *) SLang_pop_pointer(&tmp, &free_p2);
  653.     case 1: p1 = (char *) SLang_pop_pointer(&tmp, &free_p1);
  654.      }
  655.    
  656.    (void) tmp;
  657.    /* I need to put a setjmp here so to catch any long jmps that occur
  658.       in the user program */
  659.    if (!SLang_Error) switch (argc)
  660.      {
  661.  
  662.     case 0:
  663.       if (type == VOID_TYPE) ((VF0_Type) fptr) ();
  664. #ifdef FLOAT_TYPE
  665.       else if (type == FLOAT_TYPE) xf = ((FF0_Type) fptr)();
  666. #endif
  667.       else ret = ((LF0_Type) fptr)();
  668.       break;
  669.  
  670.     case 1:
  671.       if (type == VOID_TYPE) ((VF1_Type) fptr)(p1);
  672. #ifdef FLOAT_TYPE
  673.       else if (type == FLOAT_TYPE) xf =  ((FF1_Type) fptr)(p1);
  674. #endif
  675.       else ret =  ((LF1_Type) fptr)(p1);
  676.       break;
  677.  
  678.     case 2:
  679.       if (type == VOID_TYPE)  ((VF2_Type) fptr)(p1, p2);
  680. #ifdef FLOAT_TYPE
  681.       else if (type == FLOAT_TYPE) xf = ((FF2_Type) fptr)(p1, p2);
  682. #endif
  683.       else ret = ((LF2_Type) fptr)(p1, p2);
  684.       break;
  685.  
  686.     case 3:
  687.       if (type == VOID_TYPE) ((VF3_Type) fptr)(p1, p2, p3);
  688. #ifdef FLOAT_TYPE
  689.       else if (type == FLOAT_TYPE) xf = ((FF3_Type) fptr)(p1, p2, p3);
  690. #endif
  691.       else ret = ((LF3_Type) fptr)(p1, p2, p3);
  692.       break;
  693.  
  694.     case 4:
  695.       if (type == VOID_TYPE) ((VF4_Type) fptr)(p1, p2, p3, p4);
  696. #ifdef FLOAT_TYPE
  697.       else if (type == FLOAT_TYPE) xf = ((FF4_Type) fptr)(p1, p2, p3, p4);
  698. #endif
  699.       else ret = ((LF4_Type) fptr)(p1, p2, p3, p4);
  700.       break;
  701.  
  702.     case 5:
  703.       if (type == VOID_TYPE) ((VF5_Type) fptr)(p1, p2, p3, p4, p5);
  704. #ifdef FLOAT_TYPE
  705.       else if (type == FLOAT_TYPE) xf = ((FF5_Type) fptr)(p1, p2, p3, p4, p5);
  706. #endif
  707.       else ret = ((LF5_Type) fptr)(p1, p2, p3, p4, p5);
  708.       break;
  709.  
  710.       default: 
  711.     SLang_doerror("Function requires too many parameters");
  712.     SLang_Error = UNKNOWN_ERROR;
  713.     break;
  714.      }
  715.  
  716.    switch(type)
  717.      {
  718.       case STRING_TYPE:
  719.     if (NULL == (char *) ret)
  720.       {
  721.          if (!SLang_Error) SLang_Error = INTRINSIC_ERROR;
  722.       }
  723.     else SLang_push_string((char *) ret); break;
  724.       case INT_TYPE:
  725.     /* For msdos, longs are 4 bytes and ints are two.  Take this
  726.        approach: */
  727.     SLang_push_integer(*(int*) &ret); break;
  728.       case VOID_TYPE: break;
  729. #ifdef FLOAT_TYPE
  730.       case FLOAT_TYPE: SLang_push_float(* (FLOAT *) &xf); break;
  731. #endif
  732.       default: SLang_Error = TYPE_MISMATCH;
  733.      }
  734.    /* I free afterword because functions that return char * may point to this
  735.       space. */
  736.    if (free_p5 == 1) FREE(p5);
  737.    if (free_p4 == 1) FREE(p4);
  738.    if (free_p3 == 1) FREE(p3);
  739.    if (free_p2 == 1) FREE(p2);
  740.    if (free_p1 == 1) FREE(p1);
  741. }
  742.  
  743. void lang_do_loops(unsigned char type, SLBlock_Type *block)
  744. {
  745.    register int i, ctrl = 0;
  746.    int ctrl1;
  747.    int first, last, one = 0;
  748.    register SLBlock_Type *obj1, *obj2, *obj3;
  749.  
  750.    obj1 = block->b.blk;
  751.  
  752.    switch (type)
  753.      {
  754.       case LANG_WHILE:
  755.       case LANG_DOWHILE:
  756.  
  757.     /* we need 2 blocks: first is the control, the second is code */
  758.     block++;
  759.     if ((block->type) != LANG_BLOCK)
  760.       {
  761.          SLang_doerror("Block needed for while.");
  762.          return;
  763.       }
  764.     obj2 = block->b.blk;
  765.  
  766.     if (type == LANG_WHILE)
  767.       {
  768.          while(!SLang_Error)
  769.            {
  770.           inner_interp(obj1);
  771.           if (Lang_Break) break;
  772.           if (SLang_pop_integer(&ctrl1)) return;
  773.           if (!ctrl1) break;
  774.           inner_interp(obj2);
  775.           if (Lang_Break) break;
  776.           Lang_Break_Condition = Lang_Continue = 0;
  777.            }
  778.       }
  779.     else while(!SLang_Error)
  780.       {
  781.          Lang_Break_Condition = Lang_Continue = 0;
  782.          inner_interp(obj1);
  783.          if (Lang_Break) break;
  784.          inner_interp(obj2);
  785.          if (SLang_pop_integer(&ctrl1)) return;
  786.          if (!ctrl1) break;
  787.       }
  788.     break;
  789.  
  790.       case LANG_CFOR:
  791.  
  792.     /* we need 4 blocks: first 3 control, the last is code */
  793.     inner_interp(obj1);
  794.  
  795.     block++;
  796.     if ((block->type) != LANG_BLOCK) goto cfor_err;
  797.     obj1 = block->b.blk;
  798.     
  799.     block++;
  800.     if ((block->type) != LANG_BLOCK) goto cfor_err;
  801.     obj2 = block->b.blk;
  802.     
  803.     block++;
  804.     if ((block->type) != LANG_BLOCK) goto cfor_err;
  805.     obj3 = block->b.blk;
  806.     
  807.     while(!SLang_Error)
  808.       {
  809.          inner_interp(obj1);       /* test */
  810.          if (SLang_pop_integer(&ctrl1)) return;
  811.          if (!ctrl1) break;
  812.          inner_interp(obj3);       /* code */
  813.          if (Lang_Break) break;
  814.          inner_interp(obj2);       /* bump */
  815.          Lang_Break_Condition = Lang_Continue = 0;
  816.       }
  817.     break;
  818.     
  819.     cfor_err:
  820.     SLang_doerror("Block needed for for.");
  821.     return;
  822.  
  823.  
  824.       case LANG_FOR:  /* 3 elements: first, last, step */
  825.     if (SLang_pop_integer(&ctrl1)) return;
  826.     if (SLang_pop_integer(&last)) return;
  827.     if (SLang_pop_integer(&first)) return;
  828.     ctrl = ctrl1;
  829.     if (ctrl >= 0)
  830.       {         
  831.          for (i = first; i <= last; i += ctrl)
  832.            {
  833.           if (SLang_Error) return;
  834.           SLang_push_integer(i);
  835.           inner_interp(obj1);
  836.           if (Lang_Break) break;
  837.           Lang_Break_Condition = Lang_Continue = 0;
  838.            }
  839.       }
  840.     else
  841.       {
  842.          for (i = first; i >= last; i += ctrl)
  843.            {
  844.           if (SLang_Error) return;
  845.           SLang_push_integer(i);
  846.           inner_interp(obj1);
  847.           if (Lang_Break) break;
  848.           Lang_Break_Condition = Lang_Continue = 0;
  849.            }
  850.       }
  851.     
  852.     break;
  853.  
  854.       case LANG_LOOP:
  855.     if (SLang_pop_integer(&ctrl1)) return;
  856.     ctrl = ctrl1;
  857.       case LANG_FOREVER:
  858.     if (type == LANG_FOREVER) one = 1;
  859.     while (one || (ctrl-- > 0))
  860.       {
  861.          if (SLang_Error) break;
  862.          inner_interp(obj1);
  863.          if (Lang_Break) break;
  864.          Lang_Break_Condition = Lang_Continue = 0;
  865.       }
  866.     break;
  867.  
  868.       default:  SLang_doerror("Unknown loop type.");
  869.      }
  870.    Lang_Break = Lang_Continue = 0;
  871.    Lang_Break_Condition = Lang_Return;
  872. }
  873.  
  874. void lang_do_ifs(register SLBlock_Type *addr)
  875. {
  876.    register unsigned char type;
  877.    int test;
  878.  
  879.    type = addr->type >> 8;
  880.    if (SLang_pop_integer(&test)) return;
  881.    if (type == LANG_IF)
  882.      {
  883.     if (!test) return;
  884.      }
  885.    else if (type == LANG_IFNOT)
  886.      {
  887.     if (test) return;
  888.      }
  889.    else if (test) addr--;   /* LANG_ELSE */
  890.    
  891.    addr--;
  892.    if (addr->type != LANG_BLOCK)  /* was & 0xFF as well */
  893.      {
  894.     SLang_doerror("Block needed.");
  895.     return;
  896.      }
  897.    inner_interp(addr->b.blk);
  898. }
  899.  
  900. void lang_do_else(unsigned char type, SLBlock_Type *addr)
  901. {
  902.    int test, status;
  903.    char *str = NULL;
  904.    SLang_Object_Type cobj;
  905.  
  906.    if (type == LANG_SWITCH)
  907.      {
  908.     if (SLang_pop(&cobj)) return;
  909.     if (IS_DATA_STRING(cobj)) str = cobj.v.s_val;
  910.      }
  911.  
  912.    while((addr->type == LANG_BLOCK) != 0)
  913.      {
  914.     if (type == LANG_SWITCH)
  915.       {
  916.          if (str == NULL) SLang_push(&cobj); else SLang_push_string(str);
  917.       }
  918.  
  919.     status = inner_interp(addr->b.blk);
  920.     if (SLang_Error || Lang_Break_Condition) return;
  921.     if (type == LANG_SWITCH)
  922.       {
  923.          if (status) break;
  924.       }
  925.  
  926.     else if (SLang_pop_integer(&test)) return;
  927.     if (((type == LANG_ANDELSE) && (test == 0))
  928.         || ((type == LANG_ORELSE) && test))
  929.       {
  930.          break;
  931.       }
  932.     addr++;
  933.      }
  934.    if (type != LANG_SWITCH) SLang_push_integer(test);
  935.    else if (str != NULL) FREE(str);
  936.    return;
  937. }
  938.  
  939. void lang_dump(char *s)
  940. {
  941.    fputs(s, stderr);
  942. }
  943.  
  944. void (*SLang_Dump_Routine)(char *) = lang_dump;
  945.  
  946. extern void do_traceback(SLang_Name_Type *nt, int locals);
  947. static SLBlock_Type *Exit_Block_Ptr;
  948.  
  949. void SLexecute_function(SLang_Name_Type *entry1)
  950. {
  951.    register int i;
  952.    register SLang_Object_Type *frame, *lvf;
  953.    register int n_locals;
  954.    register SLang_Name_Type *entry = entry1;
  955.    SLBlock_Type *val;
  956.    static char buf[96];
  957.    int trace_max, j;
  958.    static int trace = 0;
  959.    SLBlock_Type *exit_block_save;
  960.  
  961.    n_locals = (entry->type) >> 8;
  962.  
  963.    exit_block_save = Exit_Block_Ptr;
  964.    Exit_Block_Ptr = NULL;
  965.    
  966.    /* need loaded?  */
  967.    if (n_locals == 255)
  968.      {
  969.     if (!SLang_load_file((char *) entry->addr)) goto the_return;
  970.     n_locals = (entry->type) >> 8;
  971.     if (n_locals == 255)
  972.       {
  973.          SLang_doerror("Function did not autoload!");
  974.              goto the_return;
  975.       }
  976.      }
  977.    
  978.    /* let the lang error propagate through since it will do no harm
  979.       and allow us to restore stack. */
  980.    val = (SLBlock_Type *) entry->addr;
  981.    /* set new stack frame */
  982.    lvf = frame = Local_Variable_Frame;
  983.    i = n_locals;
  984.    if ((lvf + i) > Local_Variable_Stack + MAX_LOCAL_STACK)
  985.      {
  986.     SLang_doerror("Local Variable Stack Overflow!");
  987.     goto the_return;
  988.      }
  989.    while(i--)
  990.      {
  991.     lvf++;
  992.     lvf->type = 0;
  993.      }
  994.    Local_Variable_Frame = lvf;
  995.    
  996.    if (SLang_Enter_Function != NULL) (*SLang_Enter_Function)(entry->name + 1);
  997.    if (SLang_Trace)
  998.      {
  999.     if ((*SLang_Trace_Function == *entry->name)
  1000.         && !strcmp(SLang_Trace_Function, entry->name)) trace = 1;
  1001.     
  1002.     trace_max = (trace > 50) ? 50 : trace - 1;
  1003.     if (trace)
  1004.       {
  1005.          for (j = 0; j < trace_max; j++) buf[j] = ' ';
  1006.          sprintf(buf + trace_max, ">>%s\n", entry->name + 1);
  1007.          (*SLang_Dump_Routine)(buf);
  1008.          trace++;
  1009.       }
  1010.     
  1011.     inner_interp(val);
  1012.     Lang_Break_Condition = Lang_Return = Lang_Break = 0;
  1013.     if (Exit_Block_Ptr != NULL) inner_interp(Exit_Block_Ptr);
  1014.     
  1015.     if (trace) 
  1016.       {
  1017.          sprintf(buf + trace_max, "<<%s\n", entry->name + 1);
  1018.          (*SLang_Dump_Routine)(buf);
  1019.          trace--;
  1020.          if (trace == 1) trace = 0;
  1021.       }
  1022.      }
  1023.    else
  1024.      {
  1025.     inner_interp(val);
  1026.     Lang_Break_Condition = Lang_Return = Lang_Break = 0;
  1027.     if (Exit_Block_Ptr != NULL) inner_interp(Exit_Block_Ptr);
  1028.      }
  1029.    
  1030.  
  1031.    if (SLang_Exit_Function != NULL) (*SLang_Exit_Function)(entry->name + 1);
  1032.    
  1033.    if (SLang_Error && SLang_Traceback)
  1034.      {
  1035.     do_traceback(entry, n_locals);
  1036.      }
  1037.    /* free local variables.... */
  1038.    lvf = Local_Variable_Frame;
  1039.    while(lvf > frame)
  1040.      {
  1041.     if (IS_DATA_STRING(*lvf)) FREE (lvf->v.s_val);
  1042.     lvf--;
  1043.      }
  1044.    Local_Variable_Frame = lvf;
  1045.   
  1046.    the_return:
  1047.    Lang_Break_Condition = Lang_Return = Lang_Break = 0;
  1048.    Exit_Block_Ptr = exit_block_save;
  1049. }
  1050.  
  1051.  
  1052.  
  1053. void do_traceback(SLang_Name_Type *nt, int locals)
  1054. {
  1055.    char buf[80];
  1056.    int i;
  1057.    SLang_Object_Type *objp;
  1058.    unsigned short stype;
  1059.    
  1060.    sprintf(buf, "S-Lang Traceback: %s\n",nt->name + 1);
  1061.    (*SLang_Dump_Routine)(buf);
  1062.    if (!locals) return;
  1063.    (*SLang_Dump_Routine)("  Local Variables:\n");
  1064.    
  1065.    for (i = 0; i < locals; i++)
  1066.      {
  1067.     objp = Local_Variable_Frame - i;
  1068.     stype = objp->type >> 8;
  1069.     
  1070.     if (STRING_TYPE == stype)
  1071.       {
  1072.          sprintf(buf, "\t$%d: \"", i);
  1073.          (*SLang_Dump_Routine)(buf);
  1074.          (*SLang_Dump_Routine)(objp->v.s_val);
  1075.          (*SLang_Dump_Routine)("\"\n");
  1076.          continue;
  1077.       }
  1078.     else if (INT_TYPE == stype)
  1079.       {
  1080.          sprintf(buf, "\t$%d: %d\n", i, objp->v.i_val);
  1081.       }
  1082. #ifdef FLOAT_TYPE
  1083.     else if (stype == FLOAT_TYPE)
  1084.       {
  1085.          sprintf(buf,"\t$%d: %g\n", i, objp->v.f_val);
  1086.       }
  1087. #endif
  1088.     else sprintf(buf, "\t$%d: ??\n", i);
  1089.     (*SLang_Dump_Routine)(buf);
  1090.      }
  1091. }
  1092.  
  1093. static void call_funptr(SLang_Name_Type *optr)
  1094. {
  1095.    SLBlock_Type objs[2];
  1096.    
  1097.    if (optr == NULL)
  1098.      {
  1099.     SLang_doerror("Object Ptr is Nil!");
  1100.     return;
  1101.      }
  1102.    
  1103.    objs[0].b.n_blk = optr;
  1104.    objs[0].type = optr->type;
  1105.    objs[1].type = 0;
  1106.    inner_interp(objs);
  1107. }
  1108.  
  1109.  
  1110. #ifdef SLANG_STATS
  1111. static unsigned long stat_counts[256];
  1112. #endif
  1113.  
  1114. void (*SLang_Interrupt)(void);
  1115.  
  1116. static int Last_Error;
  1117. void (*user_clear_error)(void);
  1118. void SLang_clear_error(void)
  1119. {
  1120.    if (Last_Error <= 0)
  1121.      {
  1122.     Last_Error = 0;
  1123.     return;
  1124.      }
  1125.    Last_Error--;
  1126.    if (user_clear_error != NULL) (*user_clear_error)();
  1127. }
  1128.  
  1129.  
  1130.  
  1131. /* inner interpreter */
  1132. int inner_interp(SLBlock_Type *addr1)
  1133. {
  1134.    register int bc = 0;
  1135.    register SLang_Object_Type *val;
  1136.    register SLBlock_Type *addr;
  1137.    SLang_Object_Type obj1, obj2, *objp;
  1138.    register unsigned short type;
  1139.    register unsigned char stype;
  1140.    int x, y, z;
  1141.    SLBlock_Type *block = NULL;
  1142.    SLBlock_Type *err_block = NULL;
  1143.    int save_err, slerr;
  1144.    
  1145. #ifdef FLOAT_TYPE
  1146.    FLOAT xf, yf, zf;
  1147.    int xc, yc;
  1148. #endif
  1149.  
  1150.    /* for systems that have no real interrupt facility (e.g. go32 on dos) */
  1151.    if (SLang_Interrupt != NULL) (*SLang_Interrupt)();
  1152.    addr = addr1;
  1153.    if (addr == NULL)
  1154.      {
  1155.     SLang_Error = UNKNOWN_ERROR;
  1156.      }
  1157.    
  1158.    while (SLang_Error == 0)
  1159.      {
  1160.     if (bc)
  1161.       {
  1162.          if (SLang_Error) break;
  1163.          if (Lang_Return || Lang_Break)
  1164.            {
  1165.           Lang_Break = 1;
  1166.           return(1);
  1167.            }
  1168.          if (Lang_Continue) return(1);
  1169.       }
  1170.     
  1171. #ifdef SLANG_STATS
  1172.     stat_counts[(unsigned char) (type & 0xFF)] += 1;
  1173. #endif
  1174.     switch (addr->type & 0xFF)
  1175.       {
  1176.        case 0:
  1177.          goto end_of_switch;
  1178.          
  1179.        case LANG_LVARIABLE:
  1180.          /* make val point to local stack */
  1181.          val =  (Local_Variable_Frame - addr->b.i_blk);
  1182.  
  1183.          /* inline push_variable here -- save function call */
  1184.          type = val -> type;
  1185.          stype = type >> 8;
  1186.          if (stype == STRING_TYPE)
  1187.            {
  1188.           SLang_push_string(val->v.s_val);
  1189.            }
  1190.          
  1191.          else if (stype == LANG_OBJ_TYPE) call_funptr(val->v.n_val);
  1192.          else
  1193.            {
  1194.           SLang_push(val);
  1195.            }
  1196.          break;
  1197.          
  1198.        case LANG_CMP:
  1199.        case LANG_BINARY:
  1200.          z = 0;
  1201. #ifndef FLOAT_TYPE
  1202.          if (SLang_pop_integer(&y) || SLang_pop_integer(&x)) return(0);
  1203. #else
  1204.          if (SLang_pop_float(&yf, &yc, &y) || SLang_pop_float(&xf, &xc, &x)) return(0);
  1205.          if (yc && xc)
  1206.            {
  1207. #endif
  1208.           switch (addr->type >> 8)
  1209.             {
  1210.                case LANG_EQ: if (x == y) z = 1; break;
  1211.                case LANG_NE: if (x != y) z = 1; break;
  1212.                case LANG_GT: if (x > y) z = 1; break;
  1213.                case LANG_GE: if (x >= y) z = 1; break;
  1214.                case LANG_LT: if (x < y) z = 1; break;
  1215.                case LANG_LE: if (x <= y) z = 1; break;
  1216.                case LANG_OR: if (x || y) z = 1; break;
  1217.                case LANG_AND: if (x && y) z = 1; break;
  1218.                case LANG_BAND: z = x & y; break;
  1219.                case LANG_BXOR: z = x ^ y; break;
  1220.                case LANG_MOD: z = x % y; break;
  1221.                case LANG_BOR: z = x | y; break;
  1222.                case LANG_PLUS: z = x + y; break;
  1223.                case LANG_MINUS: z = x - y; break;
  1224.                case LANG_TIMES: z = x * y; break;
  1225.                case LANG_DIVIDE: 
  1226.                if (y == 0) 
  1227.              {
  1228.                 SLang_Error = DIVIDE_ERROR;
  1229.                 return(0);
  1230.              }
  1231.                z = x / y; break;   /* y == 0? */
  1232.                case LANG_SHL: z = x << y; break;
  1233.                case LANG_SHR: z = x >> y; break;
  1234.                default: SLang_Error = INTERNAL_ERROR;
  1235.                return(0);
  1236.             }
  1237.           SLang_push_integer(z);
  1238.           /* binary */
  1239. #ifdef FLOAT_TYPE
  1240.            }
  1241.          else 
  1242.            {
  1243.           switch (addr->type >> 8)
  1244.             {
  1245.                case LANG_SHR: 
  1246.                case LANG_SHL: SLang_Error = TYPE_MISMATCH; return(0);
  1247.                
  1248.                case LANG_EQ: if (xf == yf) z = 1; break;
  1249.                case LANG_NE: if (xf != yf) z = 1; break;
  1250.                case LANG_GT: if (xf > yf) z = 1; break;
  1251.                case LANG_GE: if (xf >= yf) z = 1; break;
  1252.                case LANG_LT: if (xf < yf) z = 1; break;
  1253.                case LANG_LE: if (xf <= yf) z = 1; break;
  1254.                case LANG_OR: if (xf || yf) z = 1; break;
  1255.                case LANG_AND: if (xf && yf) z = 1; break;
  1256.                case LANG_PLUS: zf = xf + yf; break;
  1257.                case LANG_MINUS: zf = xf - yf; break;
  1258.                case LANG_TIMES: zf = xf * yf; break;
  1259.                case LANG_DIVIDE:
  1260.                if (yf == 0.0)
  1261.              {
  1262.                 SLang_Error = DIVIDE_ERROR;
  1263.                 return(0);
  1264.              }
  1265.                zf = xf / yf; break;   /* y == 0? */
  1266.              default:
  1267.                SLang_Error = INTERNAL_ERROR;
  1268.                return(0);
  1269.             }
  1270.           if ((addr->type & 0xFF) == LANG_CMP) SLang_push_integer(z);
  1271.           else SLang_push_float(zf);
  1272.            }
  1273.          
  1274.          /* binary */
  1275. #endif /* FLOAT */
  1276.          break;
  1277.       
  1278.        case LANG_INTRINSIC:
  1279.          lang_do_intrinsic(addr->b.n_blk);
  1280.          if (SLang_Error && SLang_Traceback)
  1281.            {
  1282.           do_traceback(addr->b.n_blk, 0);
  1283.            }
  1284.          break;
  1285.          
  1286.        case LANG_LITERAL:        /* a constant */
  1287.          obj1.type = addr->type;
  1288.          stype = obj1.type >> 8;
  1289. #ifdef FLOAT_TYPE
  1290.          /* The value is a pointer to the float */
  1291.          if (stype == FLOAT_TYPE)
  1292.            {
  1293.           obj1.v.f_val = *addr->b.f_blk;
  1294.            }
  1295.          else 
  1296. #endif
  1297.          obj1.v.l_val = addr->b.l_blk;
  1298.          SLang_push(&obj1);
  1299.          break;
  1300.          
  1301.        case LANG_BLOCK:
  1302.          stype = addr->type >> 8;
  1303.          if (stype == ERROR_BLOCK) err_block = addr;
  1304.          else if (stype == EXIT_BLOCK)
  1305.            Exit_Block_Ptr = addr->b.blk;
  1306.          else if (block == NULL) block =  addr;
  1307.          break;
  1308.          
  1309.        case LANG_DIRECTIVE:
  1310.          if (addr->type & (LANG_EQS_MASK << 8))
  1311.            {
  1312.           lang_do_eqs(addr);
  1313.           break;
  1314.            }
  1315.          type = addr->type;
  1316.          if (!block) SLang_doerror("No Blocks!");
  1317.          else if (type & (LANG_IF_MASK << 8)) lang_do_ifs(addr);
  1318.          else if (type & (LANG_ELSE_MASK << 8)) lang_do_else(type >> 8, block);
  1319.          else if (type & (LANG_LOOP_MASK << 8)) lang_do_loops(type >> 8, block);
  1320.          /* else SLang_doerror("Unknown directive!"); */
  1321.          block = 0;
  1322.          bc = Lang_Break_Condition;
  1323.          break;
  1324.       
  1325.        case LANG_UNARY:
  1326.          stype = addr->type >> 8;
  1327. #ifndef FLOAT_TYPE
  1328.          if (SLang_pop_integer(&z)) return(0);
  1329.          switch (stype)
  1330.            {
  1331.           case LANG_SQR: z = z * z; break;
  1332.           case LANG_MUL2: z = z * 2; break;
  1333.           case LANG_NOT:  z = !z; break;
  1334.           case LANG_BNOT:  z = ~z; break;
  1335.           case LANG_CHS:  z = -z; break;
  1336.           case LANG_ABS: z = abs(z); break;
  1337.           case LANG_SIGN: z = (z >= 0) ? 1 :  -1; break;
  1338.           default: SLang_Error = INTERNAL_ERROR; return(0);
  1339.            }
  1340.          SLang_push_integer(z);
  1341. #else
  1342.          if (stype == LANG_CHS)
  1343.            {
  1344.           if (SLang_pop_float(&zf, &xc, &z)) return(0);
  1345.           if (xc) SLang_push_integer(-z); else SLang_push_float(-zf);
  1346.            }
  1347.          else if (stype == LANG_SQR)
  1348.            {
  1349.           if (SLang_pop_float(&zf, &xc, &z)) return(0);
  1350.           if (xc) SLang_push_integer(z * z); else SLang_push_float(zf * zf);
  1351.            }
  1352.          else if (stype == LANG_MUL2)
  1353.            {
  1354.           if (SLang_pop_float(&zf, &xc, &z)) return(0);
  1355.           if (xc) SLang_push_integer(z << 1); else SLang_push_float(2.0 * zf);
  1356.            }
  1357.          else if (stype == LANG_ABS)
  1358.            {
  1359.           if (SLang_pop_float(&zf, &xc, &z)) return(0);
  1360.           if (xc) SLang_push_integer(abs(z)); 
  1361.           else SLang_push_float((FLOAT) fabs((double) zf));
  1362.            }
  1363.          
  1364.          else
  1365.            {
  1366.           if (SLang_pop_integer(&z)) return(0);
  1367.           if (stype == LANG_NOT) z = !z;
  1368.           else if (stype == LANG_BNOT) z = ~z;
  1369.           else
  1370.             {
  1371.                SLang_Error = INTERNAL_ERROR;
  1372.                return(0);
  1373.             }
  1374.           SLang_push_integer(z);
  1375.            }
  1376. #endif
  1377.          break;
  1378.          
  1379.        case LANG_FUNCTION:
  1380.          SLexecute_function(addr->b.n_blk);
  1381.          bc = Lang_Break_Condition;
  1382.          break;
  1383.     
  1384.        case LANG_GVARIABLE: 
  1385.            SLang_push_variable((SLang_Object_Type *) addr->b.n_blk->addr);
  1386.            break;
  1387.          
  1388.        case LANG_IVARIABLE:
  1389.        case LANG_RVARIABLE:
  1390.          
  1391.          switch(addr->type >> 8)
  1392.            {
  1393.         case ARRAY_TYPE:
  1394.           obj1.type = addr->type;
  1395.           obj1.v.i_val = (int) addr->b.n_blk->addr;
  1396.           SLang_push (&obj1);
  1397.           break;
  1398.  
  1399.         case STRING_TYPE:
  1400.           SLang_push_string((char *) addr->b.n_blk->addr);
  1401.           break;
  1402.         case INT_TYPE: 
  1403.           SLang_push_integer(*(int *) addr->b.n_blk->addr); 
  1404.           break;
  1405. #ifdef FLOAT_TYPE
  1406.         case FLOAT_TYPE: 
  1407.           SLang_push_float(*(FLOAT *) addr->b.n_blk->addr); 
  1408.           break;
  1409. #endif
  1410.           
  1411.           default: SLang_doerror("Unsupported Type!");
  1412.            }
  1413.          
  1414.          break;
  1415.  
  1416.        case LANG_RETURN: 
  1417.          Lang_Break_Condition = Lang_Return = Lang_Break = 1; return(1);
  1418.        case LANG_BREAK: 
  1419.          Lang_Break_Condition = Lang_Break = 1; return(1);
  1420.        case LANG_CONTINUE: 
  1421.          Lang_Break_Condition = Lang_Continue = 1; return(1);
  1422.          
  1423.        case LANG_EXCH: if (SLang_pop(&obj1) || SLang_pop(&obj2)) return(1);
  1424.          SLang_push(&obj1); SLang_push(&obj2);
  1425.          break;
  1426.  
  1427.        case LANG_LABEL:
  1428.          if (SLang_pop_integer(&z) || !z) return(0);
  1429.          break;
  1430.  
  1431.        case LANG_LOBJPTR:
  1432.          objp = (Local_Variable_Frame - addr->b.i_blk);
  1433.          if (objp->type == 0)
  1434.            {
  1435.           SLang_doerror("Local variable pointer not initialized.");
  1436.           break;
  1437.            }
  1438.          
  1439.          obj1.v.n_val = objp->v.n_val;
  1440.          obj1.type = LANG_DATA | (LANG_OBJ_TYPE << 8);
  1441.          SLang_push(&obj1);
  1442.          break;
  1443.          
  1444.        case LANG_GOBJPTR:
  1445.          obj1.v.n_val = addr->b.n_blk;
  1446.          obj1.type = LANG_DATA | (LANG_OBJ_TYPE << 8);
  1447.          SLang_push(&obj1);
  1448.          break;
  1449.                   
  1450.        case LANG_X_ERROR: 
  1451.          if (err_block != NULL) 
  1452.            {
  1453.           inner_interp(err_block->b.blk);
  1454.           if (SLang_Error) err_block = NULL;
  1455.            }
  1456.          else SLang_doerror("No Error Block");
  1457.          bc = Lang_Break_Condition;
  1458.          break;
  1459.          
  1460.        /* default : SLang_doerror("Run time error."); */
  1461.       }
  1462.     
  1463.     addr++;
  1464.      }
  1465.    
  1466.    end_of_switch:
  1467.    
  1468.    if ((SLang_Error) && (err_block != NULL) && 
  1469.        ((SLang_Error == USER_BREAK) || (SLang_Error == INTRINSIC_ERROR)))
  1470.      {
  1471.     save_err = Last_Error++;
  1472.         slerr = SLang_Error;
  1473.     SLang_Error = 0;
  1474.     inner_interp(err_block->b.blk);
  1475.     if (Last_Error <= save_err)
  1476.       {
  1477.          /* Caught error and cleared it */
  1478.          Last_Error = save_err;
  1479.          if (Lang_Break_Condition == 0) inner_interp(addr);
  1480.       }
  1481.     else 
  1482.       {
  1483.          Last_Error = save_err;
  1484.          SLang_Error = slerr;
  1485.       }
  1486.      }
  1487.    
  1488.    return(1);
  1489. }
  1490.  
  1491. /* Hash value of current item to search in table */
  1492. static unsigned char Hash;
  1493.  
  1494. static unsigned char compute_hash(unsigned char *s)
  1495. {
  1496.    register unsigned char *ss = s;
  1497.    register unsigned int h = 0;
  1498.    while (*ss) h += (unsigned int) *ss++ + (h << 2);
  1499.    
  1500.    
  1501.    if (0 == (Hash = (unsigned char) h))
  1502.      {
  1503.     Hash = (unsigned char) (h >> 8);
  1504.     if (!Hash) Hash = *s;
  1505.      }
  1506.    
  1507.    return(Hash);
  1508. }
  1509.  
  1510. SLang_Name_Type *SLang_locate_name_in_table(char *name, SLang_Name_Type *table, SLang_Name_Type *t0, int max)
  1511. {
  1512.    register SLang_Name_Type *t = t0, *tmax = table + max;
  1513.    register char h = Hash, h1;
  1514.    
  1515.    /* while(t != tmax) && (nm = t->name, (h1 = *nm) != 0)) */
  1516.    while(t != tmax)
  1517.      {
  1518.     h1 = *t->name;
  1519.     /* h is never 0 */
  1520.     if ((h1 == h) && !strcmp(t->name + 1,name))
  1521.       {
  1522. #ifdef SLANG_STATS
  1523.          t->n++;
  1524. #endif
  1525.          return(t);
  1526.       }
  1527.     else if (h1 == 0) break;
  1528.     t++;
  1529.      }
  1530.    if (t == tmax) return(NULL);
  1531.    return(t);
  1532. }
  1533.  
  1534. void SLang_trace_fun(char *f)
  1535. {
  1536.    SLang_Trace = 1;
  1537.    compute_hash((unsigned char *) f);
  1538.    *SLang_Trace_Function = Hash;
  1539.    strcpy((char *) SLang_Trace_Function + 1, f);
  1540. }
  1541.  
  1542. #ifdef SLANG_STATS
  1543. int lang_dump_stats(char *file)
  1544. {
  1545.    SLang_Name_Type *t = Lang_Intrinsic_Name_Table;
  1546.    int i;
  1547.    FILE *fp;
  1548.    if ((fp = fopen(file, "w")) == NULL) return(0);
  1549.    while (*t->name != 0)
  1550.      {
  1551.     fprintf(fp, "%3d\t%3d\t%s\n", t->n, (int) (unsigned char) *t->name, t->name + 1);
  1552.     t++;
  1553.      }
  1554.    for (i = 0; i < 256; i++) fprintf(fp, "Count %d: %lu\n", i, stat_counts[i]);
  1555.  
  1556.    fclose(fp);
  1557.    return(1);
  1558. }
  1559. #endif
  1560.  
  1561. /* before calling this routine, make sure that Hash is up to date */
  1562. SLang_Name_Type *SLang_locate_global_name(char *name)
  1563. {   
  1564.    SLName_Table *nt;
  1565.    SLang_Name_Type *t;
  1566.    int ofs;
  1567.    
  1568.    nt = SLName_Table_Root;
  1569.    while (nt != NULL)
  1570.      {
  1571.     t = nt->table;
  1572.     
  1573.     if ((ofs = nt->ofs[Hash]) != -1)
  1574.       {
  1575.          t = SLang_locate_name_in_table(name, t, t + ofs, nt->n);
  1576.          if ((t != NULL) && (*t->name != 0)) return(t);
  1577.       }
  1578.     
  1579.     nt = nt->next;
  1580.      }
  1581.    ofs = SLang_Name_Table_Ofs [Hash];
  1582.    if (ofs == -1) ofs = SLang_Name_Table_Ofs [0];
  1583.    return SLang_locate_name_in_table(name, SLang_Name_Table, SLang_Name_Table + ofs, LANG_MAX_SYMBOLS);
  1584. }
  1585.  
  1586.  
  1587.  
  1588. SLang_Name_Type *SLang_locate_name(char *name)
  1589. {
  1590.    SLang_Name_Type *t;
  1591.  
  1592.    (void) compute_hash((unsigned char *) name);
  1593.    
  1594.    t = Lang_Local_Variable_Table;
  1595.  
  1596.    if (t != NULL)
  1597.      {
  1598.     t = SLang_locate_name_in_table(name, t, t, Local_Variable_Number);
  1599.     /* MAX_LOCAL_VARIABLES */
  1600.      }
  1601.    
  1602.    if ((t == NULL) || (*t->name == 0)) t = SLang_locate_global_name(name);
  1603.    return(t);
  1604. }
  1605.  
  1606.  
  1607. /* check syntax.  Allowed chars are: $!_?AB..Zab..z0-9 */
  1608. static int lang_check_name(char *name)
  1609. {
  1610.    register char *p, ch;
  1611.    char *err = "Name Syntax";
  1612.    
  1613.    p = name;
  1614.    while ((ch = *p++) != 0)
  1615.      {
  1616.     if ((ch >= 'a') && (ch <= 'z')) continue;
  1617.     if ((ch >= 'A') && (ch <= 'Z')) continue;
  1618.     if ((ch >= '0') && (ch <= '9')) continue;
  1619.     if ((ch == '_') || (ch == '$') || (ch == '!') || (ch == '?')) continue;
  1620.     SLang_doerror(err);
  1621.     return(0);
  1622.      }
  1623.  
  1624.    p--;
  1625.    if ((int) (p - name) > LANG_MAX_NAME_LEN)
  1626.      {
  1627.     SLang_doerror("Name too long.");
  1628.     return(0);
  1629.      }
  1630.    return (1);
  1631. }
  1632.  
  1633.  
  1634.  
  1635. void SLadd_name(char *name, long addr, unsigned short type)
  1636. {
  1637.    SLang_Name_Type *entry;
  1638.    unsigned char stype;
  1639.    int ofs, this_ofs;
  1640.    if (!lang_check_name(name)) return;
  1641.    if (NULL == (entry = SLang_locate_name(name)))
  1642.      {
  1643.     SLang_doerror("Table size exceeded!");
  1644.     return;  /* table full */
  1645.      }
  1646.    
  1647.    stype = entry->type & 0xFF;
  1648.    
  1649.    if ((stype == LANG_INTRINSIC) || (stype == LANG_IVARIABLE)
  1650.        || (stype == LANG_RVARIABLE))
  1651.      {
  1652.     SLang_Error = DUPLICATE_DEFINITION;
  1653.     return;
  1654.      }   
  1655.  
  1656.    if (*entry->name != 0)
  1657.      {
  1658.     /* 255 denotes that the function needs autoloaded. */
  1659.     if (stype == LANG_FUNCTION)
  1660.       {
  1661.          if ((entry->type >> 8) != 255)
  1662.            lang_free_branch((SLBlock_Type *) entry->addr);
  1663.          FREE(entry->addr);
  1664.       }
  1665.      }
  1666.    else 
  1667.      {
  1668.     strcpy(entry->name + 1, name);
  1669.     *entry->name = (char) Hash;
  1670.     ofs = SLang_Name_Table_Ofs [Hash];
  1671.     this_ofs = (int) (entry - SLang_Name_Table);
  1672.     if (ofs == -1)               /* unused */
  1673.       {
  1674.          SLang_Name_Table_Ofs [Hash] = this_ofs;
  1675.          SLang_Name_Table_Ofs [0] = this_ofs;
  1676.       }
  1677.      }
  1678.  
  1679.    entry->addr = (long) addr;
  1680.    entry->type = type;
  1681. }
  1682.  
  1683. void SLang_autoload(char *name, char *file)
  1684. {
  1685.    unsigned short type;
  1686.    long f;
  1687.  
  1688.    type = LANG_FUNCTION | (255 << 8);
  1689.    f = (long) SLmake_string(file);
  1690.  
  1691.    SLadd_name(name, f, type);
  1692. }
  1693.  
  1694. void lang_define_function(char *name)
  1695. {
  1696.    long addr;
  1697.    unsigned short type;
  1698.    
  1699.    addr = (long) Lang_Function_Body;
  1700.    type = LANG_FUNCTION | (Local_Variable_Number << 8);
  1701.    
  1702.    if (name != NULL)
  1703.      {
  1704.     SLadd_name(name, addr, type);
  1705.      }
  1706.    
  1707.    /* terminate function */
  1708.    Lang_Object_Ptr->type = 0;
  1709.    
  1710.    if (SLang_Error) return;
  1711.    Lang_Defining_Function = 0;
  1712.    if (Lang_Local_Variable_Table != NULL) FREE(Lang_Local_Variable_Table);
  1713.    Lang_Local_Variable_Table = NULL;
  1714.    Local_Variable_Number = 0;
  1715.  
  1716.    Lang_Object_Ptr = Lang_Interp_Stack_Ptr;   /* restore pointer */
  1717. }
  1718.  
  1719. /* call inner interpreter or return for more */
  1720. void lang_try_now(void)
  1721. {
  1722.    SLBlock_Type *old_stack, *old_stack_ptr, *old_int_stack_ptr;
  1723.    SLBlock_Type new_stack[SLANG_MAX_TOP_STACK];
  1724.    int i;
  1725.  
  1726.    if (Lang_Defining_Function || Lang_Defining_Block)
  1727.      {
  1728.     Lang_Object_Ptr++;
  1729.     return;
  1730.      }
  1731.  
  1732.    /* This is the entry point into the inner interpreter.  As a result, it
  1733.       is also the exit point of the inner interpreter.  So it is necessary to
  1734.       clean up if there was an error.
  1735.     */
  1736.  
  1737.    (Lang_Object_Ptr + 1)->type = 0;  /* so next command stops after this */
  1738.  
  1739.    /* now before entering the inner interpreter, we make a new stack so that
  1740.       we are able to be reentrant */
  1741.    
  1742.    for (i = 1; i < 4; i++)
  1743.      {
  1744.     new_stack[i].type = 0;
  1745.     new_stack[i].b.blk = NULL;
  1746.      }
  1747.    
  1748.    /* remember these values */
  1749.    old_int_stack_ptr = Lang_Interp_Stack_Ptr;
  1750.    old_stack_ptr = Lang_Object_Ptr;
  1751.    old_stack = Lang_Interp_Stack;
  1752.  
  1753.    /* new values for reentrancy */
  1754.    Lang_Interp_Stack_Ptr = Lang_Object_Ptr = Lang_Interp_Stack = new_stack;
  1755.  
  1756.    /* now do it */
  1757.    inner_interp(old_stack);
  1758.  
  1759.    /* we are back so restore old pointers */
  1760.    Lang_Interp_Stack_Ptr = old_int_stack_ptr;
  1761.    Lang_Object_Ptr = old_stack_ptr;
  1762.    Lang_Interp_Stack = old_stack;
  1763.  
  1764.    /* now free blocks from the current interp_stack.  There can only 
  1765.       be blocks since they are only objects not evaluated immediately */
  1766.  
  1767.    while(Lang_Object_Ptr != Lang_Interp_Stack)
  1768.      {
  1769.     /* note that top object is not freed since it was not malloced */
  1770.     Lang_Object_Ptr--;
  1771.     /* FREE(Lang_Object_Ptr->value); */
  1772.     lang_free_branch(Lang_Object_Ptr->b.blk);
  1773.      }
  1774.  
  1775.    /* now free up the callocd stack. 
  1776.    FREE(new_stack); */
  1777. }
  1778.  
  1779.  
  1780. #define eqs(a,b) ((*(a) == *(b)) && !strcmp(a,b))
  1781. int SLang_execute_function(char *name)
  1782. {
  1783.    unsigned char type;
  1784.    SLang_Name_Type *entry;
  1785.    if ((NULL == (entry = SLang_locate_name(name))) || (*entry->name == 0)) return(0);
  1786.    type = entry->type & 0xFF;
  1787.    if (type == LANG_FUNCTION) SLexecute_function(entry);
  1788.    else if (type == LANG_INTRINSIC)
  1789.      lang_do_intrinsic(entry);
  1790.    else return(0);
  1791.    if (SLang_Error) SLang_doerror(NULL);
  1792.    return(1);
  1793. }
  1794.  
  1795. /* return S-Lang function or NULL */
  1796. SLang_Name_Type *SLang_get_function (char *name)
  1797. {
  1798.    SLang_Name_Type *entry;
  1799.    
  1800.    if ((NULL == (entry = SLang_locate_name(name))) || (*entry->name == 0)) 
  1801.      return NULL;
  1802.    if ((entry->type & 0xFF) == LANG_FUNCTION)
  1803.      {
  1804.     return entry;
  1805.      }
  1806.    return NULL;
  1807. }
  1808.  
  1809. /* Look for name ONLY in local or global slang tables */
  1810. static SLang_Name_Type *SLang_locate_slang_name (char *name)
  1811. {
  1812.    SLang_Name_Type *entry;
  1813.    int ofs;
  1814.    
  1815.    compute_hash ((unsigned char *) name);
  1816.    /* try local table first */
  1817.    entry = Lang_Local_Variable_Table;
  1818.    if (entry != NULL)
  1819.      {
  1820.     entry = SLang_locate_name_in_table(name, entry, entry, Local_Variable_Number);
  1821.      }
  1822.    if ((entry == NULL) || (*entry->name == 0))
  1823.      {
  1824.     ofs = SLang_Name_Table_Ofs [Hash];
  1825.     if (ofs == -1) ofs = SLang_Name_Table_Ofs [0];
  1826.     entry = SLang_locate_name_in_table(name, SLang_Name_Table, SLang_Name_Table + ofs, LANG_MAX_SYMBOLS);
  1827.      }
  1828.    return entry;
  1829. }
  1830.  
  1831. #if 0
  1832. static void make_name_ptr(char *name)
  1833. {
  1834.    SLang_Name_Type *n;
  1835.    SLang_Object_Type obj;
  1836.    
  1837.    n = SLang_locate_name(name);
  1838.    
  1839.    if ((n == NULL) || (*n->name == 0))
  1840.      {
  1841.     SLang_doerror("Object is undefined.");
  1842.     return;
  1843.      }
  1844.    
  1845.    obj.type = LANG_DATA | (LANG_OBJ_TYPE << 8);
  1846.    
  1847.    if ((n->obj.type >> 8) == LANG_OBJ_TYPE) obj.value = n->obj.value;
  1848.    else obj.value = (long) n;
  1849.    SLang_push (&obj);
  1850. }
  1851. #endif
  1852.  
  1853. static int lang_exec(char *name, int all)
  1854. {
  1855.    SLang_Name_Type *entry;
  1856.    short type;
  1857.    int ptr_type = 0;
  1858.    
  1859.    
  1860.    if (all && eqs(name, "EXECUTE_ERROR_BLOCK"))
  1861.      {
  1862.     Lang_Object_Ptr->type = LANG_X_ERROR;
  1863.     Lang_Object_Ptr->b.blk = NULL;
  1864.      }
  1865.    else
  1866.      {
  1867.     if (*name == '&')
  1868.       {
  1869.          name++;
  1870.          ptr_type = 1;
  1871.       }
  1872.     
  1873.     if (all) entry = SLang_locate_name(name);
  1874.     else entry = SLang_locate_slang_name (name);
  1875.     if ((entry == NULL) || (*entry->name == 0)) return(0);
  1876.  
  1877.              
  1878.     type = entry->type;
  1879.     if (ptr_type)
  1880.       {
  1881.          Lang_Object_Ptr->type = type == LANG_LVARIABLE ? LANG_LOBJPTR : LANG_GOBJPTR;
  1882.       }
  1883.     else
  1884.       {
  1885.          Lang_Object_Ptr->type = type;
  1886.       }
  1887.     
  1888.     if (type == LANG_LVARIABLE)
  1889.       {
  1890.          Lang_Object_Ptr->b.i_blk = (int) entry->addr;
  1891.       }
  1892.     else
  1893.       {
  1894.          Lang_Object_Ptr->b.n_blk = entry;
  1895.       }
  1896.      }
  1897.    
  1898.    lang_try_now();
  1899.    return(1);
  1900. }
  1901.  
  1902.  
  1903.  
  1904. int lang_try_binary(char *t)
  1905. {
  1906.    int ssub;
  1907.    unsigned char sub, type;
  1908.    ssub = 0;
  1909.  
  1910.    if (0 == (ssub = slang_eqs_name(t, Lang_Binaries))) return(0);
  1911.  
  1912.    if (ssub < 0)
  1913.      {
  1914.     ssub = -ssub;
  1915.     type = LANG_BINARY;
  1916.      }
  1917.    else type = LANG_CMP;
  1918.    sub = (unsigned char) ssub;
  1919.  
  1920.    Lang_Object_Ptr->type = type | (sub << 8);
  1921.    Lang_Object_Ptr->b.blk = NULL;         /* not used */
  1922.  
  1923.    lang_try_now();
  1924.    return(1);
  1925. }
  1926.  
  1927. int lang_try_unary(char *t)
  1928. {
  1929.    unsigned char ssub, type;
  1930.  
  1931.    if (eqs(t, "~")) ssub = LANG_BNOT;
  1932.    else if (eqs(t, "not")) ssub = LANG_NOT;
  1933.    else if (eqs(t, "chs")) ssub = LANG_CHS;
  1934.    else if (eqs(t, "sign")) ssub = LANG_SIGN;
  1935.    else if (eqs(t, "abs")) ssub = LANG_ABS;
  1936.    else if (eqs(t, "sqr")) ssub = LANG_SQR;
  1937.    else if (eqs(t, "mul2")) ssub = LANG_MUL2;
  1938.    else return(0);
  1939.  
  1940.    type = LANG_UNARY;
  1941.  
  1942.    Lang_Object_Ptr->type = type | (ssub << 8);
  1943.    Lang_Object_Ptr->b.blk = NULL;         /* not used */
  1944.  
  1945.    lang_try_now();
  1946.    return(1);
  1947. }
  1948.  
  1949. void lang_begin_function(void)
  1950. {
  1951.    if (Lang_Defining_Function || Lang_Defining_Block)
  1952.      {
  1953.     SLang_doerror("Function nesting illegal.");
  1954.     return;
  1955.      }
  1956.  
  1957.    Lang_Defining_Function = 1;
  1958.  
  1959.    /* make initial size for 3 things */
  1960.    Lang_FBody_Size = 3; 
  1961.    if (NULL == (Lang_Function_Body = (SLBlock_Type *)
  1962.           CALLOC(Lang_FBody_Size, sizeof(SLBlock_Type))))
  1963.      {
  1964.     SLang_doerror("Calloc error defining function.");
  1965.     return;
  1966.      }
  1967.    /* function definitions should be done only at top level so it should be
  1968.       safe to do this: */
  1969.    Lang_Interp_Stack_Ptr = Lang_Object_Ptr;
  1970.    Lang_Object_Ptr = Lang_FBody_Ptr = Lang_Function_Body;
  1971.    return;
  1972. }
  1973.  
  1974. void lang_end_block(void)
  1975. {
  1976.    SLBlock_Type *node, *branch;
  1977.    Lang_Block_Depth--;
  1978.  
  1979.    /* terminate the block */
  1980.    Lang_Object_Ptr->type = 0;
  1981.  
  1982.    branch = Lang_Block_Body;
  1983.  
  1984.    if (Lang_Block_Depth == -1)         /* done */
  1985.      {
  1986.     if (Lang_Defining_Function)
  1987.       {
  1988.          node = Lang_FBody_Ptr++;
  1989.       }
  1990.     else node = Lang_Interp_Stack_Ptr;   /* on small stack */
  1991.      }
  1992.    else                                /* pop previous block */
  1993.      {
  1994.     Lang_BBody_Size = Lang_Block_Stack[Lang_Block_Depth].size;
  1995.     Lang_Block_Body = Lang_Block_Stack[Lang_Block_Depth].body;
  1996.     node = Lang_Block_Stack[Lang_Block_Depth].ptr;
  1997.      }
  1998.  
  1999.    node->type = LANG_BLOCK;
  2000.    node->b.blk = branch;
  2001.    Lang_Object_Ptr = node + 1;
  2002.    Lang_Defining_Block--;
  2003. }
  2004.  
  2005. void lang_begin_block(void)
  2006. {
  2007.    if (Lang_Block_Depth == LANG_MAX_BLOCKS - 1)
  2008.      {
  2009.     SLang_doerror("Block Nesting too deep.");
  2010.     SLang_Error = UNKNOWN_ERROR;
  2011.     return;
  2012.      }
  2013.    /* push the current block onto the stack */
  2014.    if (Lang_Block_Depth > -1)
  2015.      {
  2016.     Lang_Block_Stack[Lang_Block_Depth].size = Lang_BBody_Size;
  2017.     Lang_Block_Stack[Lang_Block_Depth].body = Lang_Block_Body;
  2018.     Lang_Block_Stack[Lang_Block_Depth].ptr = Lang_Object_Ptr;
  2019.      }
  2020.  
  2021.    /* otherwise this is first block so save function pointer */
  2022.    else if (Lang_Defining_Function) Lang_FBody_Ptr = Lang_Object_Ptr;
  2023.    else Lang_Interp_Stack_Ptr = Lang_Object_Ptr;
  2024.  
  2025.    Lang_BBody_Size = 5;    /* 40 bytes */
  2026.    if (NULL == (Lang_Block_Body = (SLBlock_Type *)
  2027.                    CALLOC(Lang_BBody_Size, sizeof(SLBlock_Type))))
  2028.       {
  2029.      SLang_Error = SL_MALLOC_ERROR;
  2030.      /* SLang_doerror("Malloc error defining block."); */
  2031.      return;
  2032.       }
  2033.    Lang_Block_Depth++;
  2034.    Lang_Defining_Block++;
  2035.    Lang_Object_Ptr = Lang_Block_Body;
  2036.    return;
  2037. }
  2038.  
  2039.  
  2040. /* see if token is a directive, and add it to current block/function */
  2041. static Lang_Name2_Type Lang_Directives[] =
  2042. {
  2043.    {"!if", LANG_IFNOT},
  2044.    {"if", LANG_IF},
  2045.    {"else", LANG_ELSE},
  2046.    {"forever", LANG_FOREVER},
  2047.    {"while", LANG_WHILE},
  2048.    {"for", LANG_CFOR},
  2049.    {"_for", LANG_FOR},
  2050.    {"loop", LANG_LOOP},
  2051.    {"switch", LANG_SWITCH},
  2052.    {"do_while", LANG_DOWHILE},
  2053.    {"andelse", LANG_ANDELSE},
  2054.    {"orelse", LANG_ORELSE},
  2055.    {(char *) NULL, (int) NULL}   
  2056. };
  2057.  
  2058.  
  2059. static int try_directive(char *t, int *flag)
  2060. {  
  2061.    unsigned char sub = 0;
  2062.    unsigned short type = LANG_DIRECTIVE;
  2063.    SLBlock_Type *lop;
  2064.    int flag_save;
  2065.    
  2066.    if ((sub = (unsigned char) slang_eqs_name(t, Lang_Directives)) != 0); /* null */
  2067.    else if (*flag && eqs(t, "ERROR_BLOCK"))
  2068.      {
  2069.     lop = Lang_Object_Ptr - 1;
  2070.     if (lop->type != LANG_BLOCK) SLang_doerror("Internal Error with error_block!");
  2071.     else lop->type = LANG_BLOCK | (ERROR_BLOCK << 8);
  2072.     return(1);
  2073.      }
  2074.    else if (*flag && eqs(t, "EXIT_BLOCK"))
  2075.      {
  2076.     lop = Lang_Object_Ptr - 1;
  2077.     if (lop->type != LANG_BLOCK) SLang_doerror("Internal Error with exit_block!");
  2078.     else lop->type = LANG_BLOCK | (EXIT_BLOCK << 8);
  2079.     return(1);
  2080.      }
  2081.    
  2082.    /* rest valid only if flag is zero */
  2083.    else if (*flag) return(0);
  2084.    else
  2085.      {
  2086.     if (Lang_Defining_Block && eqs(t, "continue")) type = LANG_CONTINUE;
  2087.     else if (Lang_Defining_Block && eqs(t, "break")) type = LANG_BREAK;
  2088.     else if (Lang_Defining_Function && eqs(t, "return")) type = LANG_RETURN;
  2089.     /* why is exch here? */
  2090.     else if (eqs(t, "exch")) type = LANG_EXCH;
  2091.     else return(0);
  2092.     *flag = 1;
  2093.      }
  2094.  
  2095.    Lang_Object_Ptr->type = type | (sub << 8);
  2096.    Lang_Object_Ptr->b.blk = 0;         /* not used */
  2097.  
  2098.    flag_save = *flag; *flag = 0;
  2099.    lang_try_now();
  2100.    *flag = flag_save;
  2101.  
  2102.    return(1);
  2103. }
  2104.  
  2105. SLang_Object_Type *lang_make_object(void)
  2106. {
  2107.    SLang_Object_Type *obj;
  2108.  
  2109.    obj = (SLang_Object_Type *) MALLOC(sizeof(SLang_Object_Type));
  2110.    if (NULL == obj)
  2111.      {
  2112.     SLang_Error = SL_MALLOC_ERROR; /* SLang_doerror("Lang: malloc error."); */
  2113.     return(0);
  2114.      }
  2115.    obj->type = 0;
  2116.    obj->v.l_val = 0;
  2117.    return obj;
  2118. }
  2119.  
  2120. int interp_variable_eqs(char *name)
  2121. {
  2122.    SLang_Name_Type *v;
  2123.    SLBlock_Type obj;
  2124.    unsigned short type;
  2125.    unsigned char stype;
  2126.    char ch;
  2127.    long value;
  2128.    int offset;
  2129.    int eq, pe, me, pp, mm;
  2130.    
  2131.    eq = LANG_GEQS - LANG_GEQS;
  2132.    pe = LANG_GPEQS - LANG_GEQS;
  2133.    me = LANG_GMEQS - LANG_GEQS;
  2134.    pp = LANG_GPP - LANG_GEQS;
  2135.    mm = LANG_GMM - LANG_GEQS;
  2136.  
  2137.    /* Name must be prefixed by one of:  =, ++, --, +=, -= 
  2138.       all of which have ascii codes less than or equal to 61 ('=') */
  2139.    
  2140.    offset = -1;
  2141.    ch = *name++;
  2142.    switch (ch)
  2143.      {
  2144.       case '=': offset = eq; break;
  2145.       case '+': 
  2146.     ch = *name++;
  2147.     if (ch == '+') offset = pp; else if (ch == '=') offset = pe;
  2148.     break;
  2149.       case '-':
  2150.     ch = *name++;
  2151.     if (ch == '-') offset = mm; else if (ch == '=') offset = me;
  2152.     break;
  2153.      }
  2154.    
  2155.    if (offset == -1) return 0;
  2156.    
  2157.    v = SLang_locate_name(name);
  2158.    if ((v == NULL) || *(v->name) == 0)
  2159.      {
  2160.     SLang_Error = UNDEFINED_NAME;
  2161.     SLang_doerror(name);
  2162.     return(1);
  2163.      }
  2164.  
  2165.    type = (v->type) & 0xFF;
  2166.    if (type == LANG_RVARIABLE)
  2167.      {
  2168.     SLang_Error = READONLY_ERROR;
  2169.     return(1);
  2170.      }
  2171.  
  2172.    if ((type != LANG_GVARIABLE) && (type != LANG_LVARIABLE)
  2173.        && (type != LANG_IVARIABLE))
  2174.      {
  2175.     SLang_Error = DUPLICATE_DEFINITION;
  2176.     return(1);
  2177.      }
  2178.  
  2179.    /* its value is location of object in name table unless it is local */
  2180.    value = (long) v;
  2181.  
  2182.    if (type == LANG_IVARIABLE)
  2183.      {
  2184.     if ((v->type >> 8) == STRING_TYPE)
  2185.       {
  2186.          SLang_Error = READONLY_ERROR;
  2187.          return(1);
  2188.       }
  2189.  
  2190.     stype = LANG_IEQS;
  2191.      }
  2192.  
  2193.    else if (type == LANG_GVARIABLE) stype = LANG_GEQS;
  2194.    else
  2195.      {
  2196.     stype = LANG_LEQS;
  2197.     value = (int) v->addr;
  2198.      }
  2199.  
  2200.    stype += offset;
  2201.    
  2202.    if (Lang_Defining_Function || Lang_Defining_Block)
  2203.      {
  2204.     Lang_Object_Ptr->type = LANG_DIRECTIVE | (stype << 8);
  2205.     Lang_Object_Ptr->b.l_blk = value;
  2206.     Lang_Object_Ptr++;
  2207.     return (1);
  2208.      }
  2209.  
  2210.    /* create an object with the required properties for next call */
  2211.    obj.type = LANG_DIRECTIVE | (stype << 8);
  2212.    obj.b.l_blk = value;
  2213.    lang_do_eqs(&obj);
  2214.    return(1);
  2215. }
  2216.  
  2217. unsigned char is_number(char *t)
  2218. {
  2219.    char *p;
  2220.    register char ch;
  2221.  
  2222.    p = t;
  2223.    if (*p == '-') p++;
  2224. #ifdef FLOAT_TYPE
  2225.    if (*p != '.') 
  2226.      {
  2227. #endif
  2228.     while ((*p >= '0') && (*p <= '9')) p++;
  2229.     if (t == p) return(STRING_TYPE);
  2230.     if (*p == 'x')
  2231.       {
  2232.          p++;
  2233.          while (ch = *p, 
  2234.             ((ch >= '0') && (ch <= '9'))
  2235.             || ((ch >= 'A') && (ch <= 'F'))) p++;
  2236.       }
  2237.     if (*p == 0) return(INT_TYPE);
  2238. #ifndef FLOAT_TYPE
  2239.     return(STRING_TYPE);
  2240. #else
  2241.      }
  2242.    
  2243.    /* now down to float case */
  2244.    if (*p == '.')
  2245.      {
  2246.     p++;
  2247.     while ((*p >= '0') && (*p <= '9')) p++;
  2248.      }
  2249.    if (*p == 0) return(FLOAT_TYPE);
  2250.    if ((*p != 'e') && (*p != 'E')) return(STRING_TYPE);
  2251.    p++;
  2252.    if (*p == '-') p++;
  2253.    while ((*p >= '0') && (*p <= '9')) p++;
  2254.    if (*p != 0) return(STRING_TYPE); else return(FLOAT_TYPE);
  2255. #endif
  2256. }
  2257.  
  2258.    
  2259.  
  2260.  
  2261. /* a literal */
  2262. int interp_push_number(char *t)
  2263. {
  2264.    int i = 0;
  2265.    unsigned char stype;
  2266.    long value = 0;
  2267. #ifdef FLOAT_TYPE
  2268.    FLOAT x = 0.0;
  2269. #endif
  2270.  
  2271.    stype = is_number(t);
  2272.    if (stype == STRING_TYPE) return(0);
  2273.    if (stype == INT_TYPE)
  2274.      {
  2275.     i = SLatoi((unsigned char *) t);
  2276.     value = (long) i;
  2277.      }
  2278.  
  2279. #ifdef FLOAT_TYPE
  2280.    else if (stype == FLOAT_TYPE)
  2281.      {
  2282.     x = atof(t);
  2283.      }
  2284. #endif
  2285.  
  2286.    if (!Lang_Defining_Block && !Lang_Defining_Function)
  2287.      {
  2288. #ifdef FLOAT_TYPE
  2289.     if (stype == INT_TYPE)
  2290.       {
  2291. #endif
  2292.          SLang_push_integer(i);
  2293. #ifdef FLOAT_TYPE
  2294.       }
  2295.     else SLang_push_float(x);
  2296. #endif
  2297.     return(1);
  2298.      }
  2299.    /* a literal */
  2300.    
  2301. #ifdef FLOAT_TYPE
  2302.    if (stype == FLOAT_TYPE)
  2303.      {
  2304.     if (NULL == (Lang_Object_Ptr->b.f_blk = (FLOAT *) MALLOC(sizeof(FLOAT))))
  2305.       {
  2306.          SLang_Error = SL_MALLOC_ERROR;
  2307.          return 1;
  2308.       }
  2309.     *Lang_Object_Ptr->b.f_blk = x;
  2310.      }
  2311.    else
  2312. #endif
  2313.    Lang_Object_Ptr->b.l_blk = value;
  2314.  
  2315.    Lang_Object_Ptr->type = LANG_LITERAL | (stype << 8);
  2316.    
  2317.    Lang_Object_Ptr++;
  2318.    return(1);
  2319. }
  2320.  
  2321. /* only supports non negative integers, use 'chs' to make negative number */
  2322.  
  2323. void lang_check_space(void)
  2324. {
  2325.    int n;
  2326.    SLBlock_Type *p;
  2327.  
  2328.    if (Lang_Interp_Stack_Ptr - Lang_Interp_Stack >= 9)
  2329.      {
  2330.     SLang_doerror("Interpret stack overflow.");
  2331.     return;
  2332.      }
  2333.  
  2334.    if (Lang_Defining_Block)
  2335.      {
  2336.     n = (int) (Lang_Object_Ptr - Lang_Block_Body);
  2337.     if (n + 1 < Lang_BBody_Size) return;   /* extra for terminator */
  2338.     p = Lang_Block_Body;
  2339.      }
  2340.    else if (Lang_Defining_Function)
  2341.      {
  2342.     n = (int) (Lang_Object_Ptr - Lang_Function_Body);
  2343.     if (n + 1 < Lang_FBody_Size) return;
  2344.     p = Lang_Function_Body;
  2345.      }
  2346.    else return;
  2347.  
  2348.    /* enlarge the space by 2 objects */
  2349.    n += 2;
  2350.    if (NULL == (p = (SLBlock_Type *) REALLOC(p, n * sizeof(SLBlock_Type))))
  2351.      {
  2352.     SLang_doerror("Lang: realloc failure.");
  2353.     return;
  2354.      }
  2355.  
  2356.    if (Lang_Defining_Block)
  2357.      {
  2358.     Lang_BBody_Size = n;
  2359.     n = (int) (Lang_Object_Ptr - Lang_Block_Body);
  2360.     Lang_Block_Body = p;
  2361.     Lang_Object_Ptr = p + n;
  2362.      }
  2363.    else
  2364.      {
  2365.     Lang_FBody_Size = n;
  2366.     n = (int) (Lang_Object_Ptr - Lang_Function_Body);
  2367.     Lang_Function_Body = p;
  2368.     Lang_Object_Ptr = p + n;
  2369.      }
  2370. }
  2371.  
  2372. int Lang_Defining_Variables = 0;
  2373.  
  2374. /* returns positive number if name is a function or negative number if it 
  2375.    is a variable.  If it is intrinsic, it returns magnitude of 1, else 2 */
  2376. int SLang_is_defined(char *name)
  2377. {
  2378.    SLang_Name_Type *t;
  2379.    unsigned char stype;
  2380.    (void) compute_hash((unsigned char *) name);
  2381.    t = SLang_locate_global_name(name);
  2382.    
  2383.    if ((t == NULL) || (*t->name == 0)) return 0;
  2384.    
  2385.    stype = t->type & 0xFF;
  2386.    switch (stype)
  2387.      {
  2388.       case LANG_FUNCTION: return(2);
  2389.       case LANG_INTRINSIC: return(1);
  2390.       case LANG_GVARIABLE: return (-2);
  2391.       default: 
  2392.     return(-1);
  2393.      }
  2394. }
  2395.  
  2396.  
  2397.  
  2398.  
  2399. char *SLang_find_name(char *name)
  2400. {
  2401.    SLang_Name_Type *n;
  2402.    
  2403.    compute_hash((unsigned char *) name);
  2404.    
  2405.    n = SLang_locate_global_name(name);
  2406.    if ((n != NULL) && (*n->name != 0))
  2407.      {
  2408.     return(n->name);
  2409.      }
  2410.    return(NULL);
  2411. }
  2412.  
  2413. void SLadd_variable(char *name)
  2414. {
  2415.    SLang_Name_Type *table;
  2416.    long value;
  2417.  
  2418.    if (!lang_check_name(name)) return;
  2419.    
  2420.    if (Lang_Defining_Function)           /* local variable */
  2421.      {
  2422.     compute_hash((unsigned char *) name);
  2423.     table = Lang_Local_Variable_Table;
  2424.     if (!Local_Variable_Number)
  2425.       {
  2426.          table = (SLang_Name_Type *) CALLOC(MAX_LOCAL_VARIABLES, sizeof(SLang_Name_Type));
  2427.          if (NULL == table)
  2428.            {
  2429.           SLang_doerror("Lang: calloc error.");
  2430.           return;
  2431.            }
  2432.          Lang_Local_Variable_Table = table;
  2433.       }
  2434.     strcpy(table[Local_Variable_Number].name + 1, name);
  2435.     *table[Local_Variable_Number].name = (char) Hash;
  2436.     table[Local_Variable_Number].type = LANG_LVARIABLE;
  2437.     table[Local_Variable_Number].addr = (long) Local_Variable_Number;
  2438.         Local_Variable_Number++;
  2439.      }
  2440.    else    if (!SLang_is_defined(name))
  2441.      {
  2442.     if (0 == (value = (long) lang_make_object())) return;
  2443.     SLadd_name(name, value, LANG_GVARIABLE);
  2444.      }
  2445. }
  2446.  
  2447. void interp_push_string(char *t)
  2448. {
  2449.    int len;
  2450.  
  2451.    /* strings come in with the quotes attached-- knock em off */
  2452.    if (*t == '"')
  2453.      {
  2454.     len = strlen(t) - 1;
  2455.     if (*(t + len) == '"') *(t + len) = 0;
  2456.     t++;
  2457.      }
  2458.  
  2459.    if (!Lang_Defining_Block && !Lang_Defining_Function)
  2460.      {
  2461.     SLang_push_string(t);
  2462.     return;
  2463.      }
  2464.  
  2465.    if (NULL == (Lang_Object_Ptr->b.s_blk = SLmake_string(t))) return;
  2466.  
  2467.    /* a literal --- not to be freed */
  2468.    Lang_Object_Ptr->type = LANG_LITERAL | (STRING_TYPE << 8);
  2469.    Lang_Object_Ptr++;
  2470. }
  2471.  
  2472. /* if an error occurs, discard current object, block, function, etc... */
  2473. void SLang_restart(int localv)
  2474. {
  2475.    int save = SLang_Error;
  2476.    SLang_Error = UNKNOWN_ERROR;
  2477.  
  2478.    SLcompile_ptr = SLcompile;
  2479.    Lang_Break = Lang_Continue = Lang_Return = 0;
  2480.    while(Lang_Defining_Block)
  2481.      {
  2482.     lang_end_block();
  2483.      }
  2484.  
  2485.    if (Lang_Defining_Function)
  2486.      {
  2487.     if (Lang_Function_Body != NULL)
  2488.       {
  2489.          lang_define_function(NULL);
  2490.          lang_free_branch(Lang_Function_Body);
  2491.          FREE(Lang_Function_Body);
  2492.       }
  2493.     if (Local_Variable_Number)
  2494.       {
  2495.          FREE(Lang_Local_Variable_Table);
  2496.          Local_Variable_Number = 0;
  2497.          Lang_Local_Variable_Table = NULL;
  2498.       }
  2499.     Lang_Defining_Function = 0;
  2500.      }
  2501.  
  2502.    SLang_Error = save;
  2503.    /* --- warning--- I need to free things on the stack! */
  2504.    if (SLang_Error == STACK_OVERFLOW) SLStack_Pointer = SLRun_Stack;
  2505.    
  2506.    Lang_Interp_Stack = Lang_Object_Ptr = Lang_Interp_Stack_Ptr = Lang_Interp_Stack_Static;
  2507.    /* This should be handled automatically */
  2508.    
  2509.    if (localv) Local_Variable_Frame = Local_Variable_Stack;
  2510.    Lang_Defining_Variables = 0;
  2511. }
  2512.  
  2513. #ifdef SL_BYTE_COMPILING
  2514.  
  2515. static int try_byte_compiled(register unsigned char *s)
  2516. {
  2517.    SLName_Table *nt;
  2518.    SLang_Name_Type *entry;
  2519.    register ofs;
  2520.    int n;
  2521.    
  2522.    if ((*s++ != '#') 
  2523.        || ((n = (int) (*s++ - '0')) < 0))
  2524.      {  
  2525.     SLang_doerror("Illegal name.");
  2526.     return 1;
  2527.      }
  2528.    if (n == 0)
  2529.      {
  2530.     try_directive ((char *) s, &n);           /* note that n is a dummy now */
  2531.     return 1;
  2532.      }
  2533.    if (n == 1) 
  2534.      {
  2535.     lang_try_binary((char *) s);
  2536.     return 1;
  2537.      }
  2538.    if (n == 2)
  2539.      {
  2540.     /* global or local, try it. */
  2541.     if (Lang_Defining_Function == -1) return 0;
  2542.     return lang_exec ((char *) s, 0);
  2543.      }
  2544.    
  2545.    n -= 3;
  2546.    /* 3 digit base 26 number */
  2547.    ofs = (*s++ - 'A');
  2548.    ofs = 26 * ofs + (*s++ - 'A');
  2549.    ofs = 26 * ofs + (*s++ - 'A');
  2550.    
  2551.    nt = SLName_Table_Root;
  2552.    while (n--) 
  2553.      {
  2554.     nt = nt->next;           /* find the correct table */
  2555.     if (nt == NULL)
  2556.       {
  2557.          SLang_doerror("Illegal name.");
  2558.          return 1;
  2559.       }
  2560.      }
  2561.    
  2562.    entry = &(nt->table[ofs]);
  2563.    
  2564.    /* table = Lang_Local_Variable_Table; */
  2565.    Lang_Object_Ptr->type = entry->obj.type;
  2566.    Lang_Object_Ptr->value = (long) entry;
  2567.    lang_try_now();
  2568.    return 1;
  2569. }
  2570. #endif
  2571.  
  2572. int SLPreprocess_Only = 0;
  2573.  
  2574. char *SLbyte_compile_name(char *name)
  2575. {
  2576.    static char code[36];
  2577.    SLang_Name_Type *t;
  2578.    SLName_Table *nt;
  2579.    int ofs, n;
  2580.    
  2581.    if (SLPreprocess_Only || (*name == 0)) return name;
  2582.  
  2583.    if (slang_eqs_name(name, Lang_Directives))
  2584.      {
  2585.     *code = '@'; code[1] = '#';  code[2] = '0';
  2586.     strcpy (code + 3, name);
  2587.     return code;
  2588.      }
  2589.    if (slang_eqs_name(name, Lang_Binaries))
  2590.      {
  2591.     *code = '@'; code[1] = '#';  code[2] = '1';
  2592.     strcpy (code + 3, name);
  2593.     return code;
  2594.      }
  2595.    
  2596.    (void) compute_hash((unsigned char *) name);
  2597.  
  2598.    /* see if it is in local table */
  2599.    t = Lang_Local_Variable_Table;
  2600.    if (t != NULL)
  2601.      {
  2602.     t = SLang_locate_name_in_table(name, t, t, Local_Variable_Number);
  2603.      }
  2604.    
  2605.    if ((t == NULL) || (t->name == 0))
  2606.      {
  2607.     /* It must be global.  Check intrinsics first */
  2608.     nt = SLName_Table_Root;
  2609.     n = 3;
  2610.     while (nt != NULL)
  2611.       {
  2612.          t = nt->table;
  2613.          
  2614.          if ((ofs = nt->ofs[Hash]) != -1)
  2615.            {
  2616.           t = SLang_locate_name_in_table(name, t, t + ofs, nt->n);
  2617.           if ((t != NULL) && (*t->name != 0)) 
  2618.             {
  2619.                ofs = (int) (t - nt->table);
  2620.                
  2621.                *code = '@'; *(code + 1) = '#';
  2622.                *(code + 2) = n + '0';
  2623.                *(code + 5) = (ofs % 26) + 'A';
  2624.                ofs = ofs / 26;
  2625.                *(code + 4) = (ofs % 26) + 'A';
  2626.                ofs = ofs / 26;
  2627.                *(code + 3) = (ofs % 26) + 'A';
  2628.                *(code + 6) = 0;
  2629.                return code;
  2630.             }
  2631.            }
  2632.          
  2633.          nt = nt->next;
  2634.          n++;
  2635.       }
  2636.     
  2637.     /* Now try global */
  2638.     t = SLang_locate_slang_name (name);
  2639.     if ((t == NULL) || (*t->name == 0)) return name;
  2640.      }
  2641.     
  2642.    *code = '@';
  2643.    code [1] = '#';
  2644.    code [2] = '2';
  2645.    strcpy (code + 3, name);
  2646.    return code;
  2647. }
  2648.  
  2649.  
  2650. void SLcompile(char *t)
  2651. {
  2652.    static int flag = 0;
  2653.    int d = 0;
  2654.    char ch = *t;
  2655.    
  2656.    if (ch == 0) return;
  2657.    lang_check_space();                 /* make sure there is space for this */
  2658.    
  2659.    
  2660.    if (!SLang_Error
  2661. #ifdef SL_BYTE_COMPILING
  2662.        && (ch != '@')
  2663. #endif
  2664.        && (ch != '"'))
  2665.      {
  2666.     if (ch == '{')
  2667.       {
  2668.          lang_begin_block();
  2669.          d = 1;
  2670.       }
  2671.     else
  2672.       {
  2673.          /* The purpose of this convoluted mess is to flag errors 
  2674.           such as  '{block} statement'  where 'statement' is not 
  2675.           somthing like 'if', '!if', 'while', ...  That is, something
  2676.           which is not supposed to follow a block. */
  2677.          d = try_directive(t, &flag);
  2678.          if ((!flag && d) || (flag && !d)) SLang_Error = SYNTAX_ERROR;
  2679.       }
  2680.     flag = 0;
  2681.      }
  2682.  
  2683. #ifdef SL_BYTE_COMPILING
  2684.    if (ch == '@') 
  2685.      {
  2686.     flag = 0; d = 0;
  2687.     if (0 == try_byte_compiled((unsigned char *) (t + 1)))
  2688.       {
  2689.          /* failure ONLY for slang functions/variables. */
  2690.          t += 3;
  2691.          ch = *t;
  2692.       }
  2693.      }
  2694. #endif
  2695.    
  2696.    if ((ch == '@') || SLang_Error || d);  /* null... */
  2697.    else if (Lang_Defining_Variables)
  2698.      {
  2699.     if (ch == ']') Lang_Defining_Variables = 0;
  2700.     else SLadd_variable(t);
  2701.      }
  2702.    else if (Lang_Defining_Function == -1) lang_define_function(t);
  2703.    else if (ch == '"') interp_push_string(t);
  2704.    else if ((ch == ':') && (Lang_Defining_Block))
  2705.      {
  2706.     Lang_Object_Ptr->type = LANG_LABEL;
  2707.     Lang_Object_Ptr->b.blk = NULL;
  2708.     Lang_Object_Ptr++;
  2709.      }
  2710.  
  2711.    else if ((ch == ')') && (Lang_Defining_Function == 1))
  2712.      {
  2713.     if (Lang_Defining_Block) SLang_doerror("Function nesting illegal.");
  2714.     else Lang_Defining_Function = -1;
  2715.      }
  2716.  
  2717.    else if (ch == '{')
  2718.      {
  2719.     lang_begin_block();
  2720.     flag = 0;
  2721.      }
  2722.  
  2723.    else if ((ch == '}') && Lang_Defining_Block)
  2724.      {
  2725.     lang_end_block();
  2726.     flag = 1;
  2727.      }
  2728.  
  2729.    else if (ch == '(')    lang_begin_function();
  2730.  
  2731.    else if (ch == '[') Lang_Defining_Variables = 1;
  2732.    else if (lang_try_binary(t));
  2733.    else if (lang_try_unary(t));
  2734.  
  2735.    /* note that order here is important */
  2736.    else if ((ch <= '9') && interp_push_number(t));
  2737.    else if ((ch <= '=') && interp_variable_eqs(t));
  2738.    else if (lang_exec(t, 1));
  2739.    else 
  2740.      {
  2741.     SLang_Error = UNDEFINED_NAME;
  2742.      }
  2743.    
  2744.  
  2745.    if (SLang_Error) 
  2746.      {    
  2747.     SLang_restart(0);
  2748.     flag = 0;
  2749.      }
  2750. }
  2751.  
  2752.  
  2753.  
  2754.  
  2755.  
  2756.  
  2757. int SLstack_depth()
  2758. {
  2759.    return (int) (SLStack_Pointer - SLRun_Stack);
  2760. }
  2761.  
  2762.  
  2763.  
  2764.  
  2765.  
  2766.  
  2767. /* #define STRCHR(x, y) ((y >= 'a') && (y <= 'z') ? NULL : ((y) == 32) || strchr(x, y)) */
  2768.  
  2769.  
  2770. Lang_Name2_Type Lang_Binaries[] = 
  2771. {
  2772.    {"+", -LANG_PLUS},
  2773.    {"-", -LANG_MINUS},
  2774.    {"*", -LANG_TIMES},
  2775.    {"/", -LANG_DIVIDE},
  2776.    {"<", LANG_LT},
  2777.    {"<=", LANG_LE},
  2778.    {"==", LANG_EQ},
  2779.    {">", LANG_GT},
  2780.    {">=", LANG_GE},
  2781.    {"!=", LANG_NE},
  2782.    {"and", LANG_AND},
  2783.    {"or", LANG_OR},
  2784.    {"mod", LANG_MOD},
  2785.    {"&", LANG_BAND},
  2786.    {"shl", LANG_SHL},
  2787.    {"shr", LANG_SHR},
  2788.    {"xor", LANG_BXOR},
  2789.    {"|", LANG_BOR},
  2790.    {(char *) NULL, (int) NULL}
  2791. };
  2792.  
  2793. static char Really_Stupid_Hash[256];
  2794.  
  2795. void SLstupid_hash()
  2796. {
  2797.    register unsigned char *p;
  2798.    register Lang_Name2_Type *d;
  2799.    
  2800.    d = Lang_Binaries;
  2801.    while ((p = (unsigned char *) (d->name)) != NULL)
  2802.      {
  2803.     Really_Stupid_Hash[*(p + 1)] = 1;
  2804.     d++;
  2805.      }
  2806.    d = Lang_Directives;
  2807.    while ((p = (unsigned char *) (d->name)) != NULL)
  2808.      {
  2809.     Really_Stupid_Hash[*(p + 1)] = 1;
  2810.     d++;
  2811.      }
  2812. }
  2813.  
  2814.    
  2815.    
  2816.  
  2817. int slang_eqs_name(char *t, Lang_Name2_Type *d_parm)
  2818. {
  2819.    register char *p;
  2820.    register char ch;
  2821.    register Lang_Name2_Type *d;
  2822.  
  2823.    ch = *t++;
  2824.    if (Really_Stupid_Hash[(unsigned char) *t] == 0) return(0);
  2825.    d = d_parm;
  2826.    while ((p = d->name) != NULL)
  2827.      {
  2828.     if ((ch == *p) && !strcmp(t, p + 1)) return(d->type);
  2829.     d++;
  2830.      }
  2831.    return(0);
  2832. }
  2833.  
  2834. /* There are 1s at positions " %\t{}[];():*,/" */
  2835. static unsigned char special_chars[256] = 
  2836. {
  2837.    0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,
  2838.    0,0,0,0,1,0,0,1,1,1,0,1,0,0,1,0,0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,
  2839.    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,1,0,0,0,0,0,
  2840.    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,1,0,0,0,0,0,0,
  2841.    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  2842.    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  2843.    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  2844.    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  2845. };
  2846.  
  2847. char *SLexpand_escaped_char(char *p, char *ch)
  2848. {
  2849.    char ch1;
  2850.    int num = 0;
  2851.    int base = 16, i = -1;
  2852.    int max = '9';
  2853.    ch1 = *p++;
  2854.    switch (ch1)
  2855.      {
  2856.       case 'n': ch1 = '\n'; break;
  2857.       case 't': ch1 = '\t'; break;
  2858.       case 'v': ch1 = '\v'; break;
  2859.       case 'b': ch1 = '\b'; break;
  2860.       case 'r': ch1 = '\r'; break;
  2861.       case 'f': ch1 = '\f'; break;
  2862.       case 'e': ch1 = 27; break;
  2863.       case 'a': ch1 = 7; break;
  2864.       case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': 
  2865.     max = '7'; base = 8; i = 2; num = ch1 - '0';
  2866.     /* fall */
  2867.     
  2868.       case 'd':                   /* decimal -- S-Lang extension */
  2869.     if (ch1 == 'd')
  2870.       {
  2871.          base = 10; i = 3;
  2872.       }
  2873.     
  2874.       case 'x':
  2875.     
  2876.     while(i--)
  2877.       {
  2878.          ch1 = *p;
  2879.          
  2880.          if ((ch1 <= max) && (ch1 >= '0'))
  2881.            {
  2882.           num = base * num + (ch1 - '0');
  2883.            }
  2884.          else if ((base == 16) && (ch1 >= 'A'))
  2885.            {
  2886.           if (ch1 >= 'a') ch1 -= 32;
  2887.           if (ch1 <= 'F')
  2888.             {
  2889.                num = base * num + 10 + (ch1 - 'A');
  2890.             }
  2891.           else break;
  2892.            }
  2893.          else break;
  2894.          p++;
  2895.       }
  2896.     ch1 = (char) num;
  2897.     
  2898.      }
  2899.    *ch = ch1;
  2900.    return p;
  2901. }
  2902.  
  2903. void SLexpand_escaped_string (register char *s, register char *t, 
  2904.                   register char *tmax)
  2905. {
  2906.    char ch;
  2907.    
  2908.    while (t < tmax)
  2909.      {
  2910.     ch = *t++;
  2911.     if (ch == '\\')
  2912.       {
  2913.          t = SLexpand_escaped_char (t, &ch);
  2914.       }
  2915.     *s++ = ch;
  2916.      }
  2917.    *s = 0;
  2918. }
  2919.  
  2920.    
  2921. int extract_token(char **linep, char *word_parm)
  2922. {
  2923.    register char ch, *line, *word = word_parm;
  2924.    int byte_comp = ((long) SLcompile != (long) SLcompile_ptr);
  2925.    int string;
  2926.    char ch1;
  2927.  
  2928.     line = *linep;
  2929.  
  2930.     /* skip white space */
  2931.     while(ch = *line++, (ch == ' ') || (ch == '\t'));
  2932.  
  2933.     if ((!ch) || (ch == '\n'))
  2934.       {
  2935.      *linep = line;
  2936.      return(0);
  2937.       }
  2938.  
  2939.    *word++ = ch;
  2940.    if (ch == '"') string = 1; else string = 0;
  2941.    if (ch == '\'')
  2942.      {
  2943.     if ((ch = *line++) != 0)
  2944.       {
  2945.          if (ch == '\\') 
  2946.            {
  2947.           line = SLexpand_escaped_char(line, &ch1);
  2948.           ch = ch1;
  2949.            }
  2950.          if (*line++ == '\'')
  2951.            {
  2952.           --word;
  2953.           sprintf(word, "%d", (int) ((unsigned char) ch));
  2954.           word += 4;  ch = '\'';
  2955.            }
  2956.          else SLang_Error = SYNTAX_ERROR;
  2957.       }
  2958.     else SLang_Error = SYNTAX_ERROR;
  2959.      }
  2960.    else  if (!special_chars[(unsigned char) ch])
  2961.      {
  2962.     while(ch = *line++, (ch > '"') || ((ch != '\n') && (ch != 0) && (ch != '"')))
  2963.       {
  2964.          if (string)
  2965.            {
  2966.           if (ch == '\\')
  2967.             {
  2968.                ch = *line++;
  2969.                if ((ch == 0) || (ch == '\n')) break;
  2970.                if (byte_comp) *word++ = '\\';
  2971.                else 
  2972.              {
  2973.                 line = SLexpand_escaped_char(line - 1, &ch1);
  2974.                 ch = ch1;
  2975.              }
  2976.             }
  2977.            }
  2978.          else if (special_chars[(unsigned char) ch])
  2979.            {
  2980.           line--;
  2981.           break;
  2982.            }
  2983.          
  2984.          *word++ = ch;
  2985.       }
  2986.      }
  2987.    
  2988.    if ((!ch) || (ch == '\n')) line--;
  2989.    if ((ch == '"') && string) *word++ = '"'; else if (string) SLang_Error = SYNTAX_ERROR;
  2990.    *word = 0;
  2991.    *linep = line;
  2992.    /* massage variable-- and ++ into --variable, etc... */
  2993.    if (((int) (word - word_parm) > 2)
  2994.        && (ch = *(word - 1), (ch == '+') || (ch == '-'))
  2995.        && (ch == *(word - 2)))
  2996.      {
  2997.     word--;
  2998.     while (word >= word_parm + 2)
  2999.       {
  3000.          *word = *(word - 2);
  3001.          word--;
  3002.       }
  3003.     *word-- = ch;
  3004.     *word-- = ch;
  3005.      }
  3006.    return(1);
  3007. }
  3008.  
  3009. void (*SLcompile_ptr)(char *) = SLcompile;
  3010.  
  3011. int SLang_add_table(SLang_Name_Type *table, char *table_name)
  3012. {
  3013.    register int i;
  3014.    SLang_Name_Type *t;
  3015.    SLName_Table *nt;
  3016.    int *ofs;
  3017.    unsigned char h;
  3018.    char *name;
  3019.    static init = 0;
  3020.    
  3021.    if (init == 0)
  3022.      {
  3023.     init = 1;
  3024.     for (i = 1; i < 256; i++) SLang_Name_Table_Ofs[i] = -1;
  3025.     SLang_Name_Table_Ofs[0] = 0;
  3026.      }
  3027.    
  3028.    if ((nt = (SLName_Table *) MALLOC(sizeof(SLName_Table))) == NULL) return(0);
  3029.    nt->table = table;
  3030.    nt->next = SLName_Table_Root;
  3031.    strcpy(nt->name, table_name);
  3032.    SLName_Table_Root = nt;
  3033.    ofs = nt->ofs;
  3034.    for (i = 0; i < 256; i++) ofs[i] = -1;
  3035.    
  3036.    /* compute hash for table */
  3037.    
  3038.    t = table;
  3039.    while (((name = t->name) != NULL) && (*name != 0))
  3040.      {
  3041.     h = compute_hash((unsigned char *) (name + 1));
  3042.     *name = (char) h;
  3043.     if (ofs[h] == -1)
  3044.       {
  3045.          ofs[h] = (int) (t - table);
  3046.       }
  3047.     t++;
  3048.      }
  3049.    nt->n = (int) (t - table);
  3050.    return(1);
  3051. }
  3052.  
  3053. extern char *SLang_extract_list_element(char *, int *, int *);
  3054.